perm filename LISP.MAC[LSP,JRA] blob
sn#189834 filedate 1975-12-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00179 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 <NEWLISP>LISP.MAC35 5-NOV-75 03:48:36 EDIT BY HARTLEY
C00029 00003
C00031 00004
C00033 00005
C00036 00006
C00037 00007
C00038 00008
C00040 00009
C00043 00010
C00046 00011
C00048 00012
C00053 00013
C00055 00014 UUO-CALLED ROUTINES
C00056 00015
C00058 00016
C00060 00017
C00062 00018
C00064 00019
C00066 00020
C00068 00021
C00071 00022
C00076 00023
C00079 00024
C00084 00025
C00087 00026
C00088 00027
C00092 00028
C00096 00029
C00098 00030
C00102 00031
C00104 00032
C00107 00033
C00109 00034
C00111 00035
C00113 00036
C00115 00037
C00116 00038
C00118 00039
C00123 00040
C00126 00041
C00129 00042
C00131 00043
C00133 00044
C00136 00045
C00137 00046
C00140 00047
C00141 00048
C00143 00049
C00147 00050
C00150 00051
C00152 00052
C00154 00053
C00156 00054
C00159 00055
C00162 00056
C00165 00057
C00166 00058
C00167 00059
C00169 00060
C00172 00061
C00176 00062
C00179 00063
C00180 00064
C00182 00065
C00184 00066
C00185 00067
C00187 00068
C00190 00069
C00192 00070
C00194 00071
C00199 00072
C00202 00073
C00204 00074
C00206 00075
C00210 00076
C00213 00077
C00215 00078
C00217 00079
C00218 00080 IEQP: CALL I2UBOX
C00220 00081
C00223 00082
C00224 00083
C00226 00084
C00228 00085
C00230 00086
C00232 00087
C00234 00088
C00236 00089
C00237 00090
C00239 00091
C00242 00092
C00244 00093
C00246 00094
C00248 00095
C00249 00096
C00251 00097
C00253 00098 GENERAL UNBOX- GET VALUE IN 1, TYPE IN 2
C00255 00099
C00259 00100
C00261 00101
C00264 00102
C00266 00103
C00268 00104
C00269 00105
C00271 00106
C00273 00107
C00276 00108
C00279 00109
C00280 00110
C00281 00111
C00283 00112
C00284 00113
C00286 00114
C00288 00115
C00290 00116
C00293 00117
C00295 00118
C00296 00119
C00297 00120
C00298 00121
C00301 00122
C00303 00123
C00305 00124
C00307 00125
C00308 00126
C00309 00127
C00311 00128
C00313 00129
C00317 00130
C00321 00131
C00322 00132
C00325 00133
C00333 00134
C00336 00135
C00342 00136
C00345 00137 READ STRING
C00347 00138
C00349 00139 CONTROL - MISCELLANEOUS MODES FOR TTY INPUT
C00352 00140
C00354 00141
C00358 00142
C00361 00143
C00365 00144
C00367 00145
C00369 00146
C00371 00147
C00373 00148
C00375 00149
C00377 00150
C00380 00151
C00382 00152
C00385 00153
C00387 00154
C00391 00155
C00392 00156
C00393 00157
C00400 00158
C00404 00159
C00405 00160
C00408 00161
C00411 00162
C00413 00163
C00415 00164
C00418 00165
C00423 00166
C00424 00167
C00426 00168
C00428 00169
C00431 00170
C00443 00171 ONE-SHOT INIT, .START OR LISP0$G FROM DDT AFTER LOADING
C00447 00172
C00450 00173
C00452 00174
C00454 00175
C00456 00176
C00460 00177
C00462 00178
C00463 00179
C00464 ENDMK
C⊗;
;<NEWLISP>LISP.MAC;35 5-NOV-75 03:48:36 EDIT BY HARTLEY
;<NEWLISP>LISP.MAC;34 30-OCT-75 11:10:11 EDIT BY LEWIS
; MAKE RATEST WORK OFF OF RATOM INSTEAD OF MKATOM AND
; MAKE 2ND ARG OF PEEKC A READTABLE.
;<HARTLEY>LISP.MAC;32 24-SEP-75 18:47:55 EDIT BY HARTLEY
;ADD VALUE CELLS
;<HARTLEY>LISP.MAC;22 28-AUG-75 18:26:17 EDIT BY HARTLEY
; FOR IMMEDIATE TYPE NUMS, NEW CONS
;<HARTLEY>LISP.MAC;16 27-AUG-75 03:06:44 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC;11 26-AUG-75 01:29:17 EDIT BY HARTLEY
;CHANGED SOME ERROR NUMBERS
;<NEWLISP>LISP.MAC;26 18-AUG-75 21:22:54 EDIT BY LEWIS
; added RETTO and deleted the defunct STKCALL.
;<HARTLEY>LISP.MAC;9 5-AUG-75 02:55:23 EDIT BY HARTLEY
;ADDED MORE COREVALS
;<LEWIS>LISP.MAC;2 30-JUL-75 20:46:00 EDIT BY LEWIS
; MAKE CLOSEF RETURN NIL IF YOU TRY TO CLOSE T OR THE DRIBBLE FILE
;<HARTLEY>LISP.MAC;7 29-JUL-75 23:39:35 EDIT BY HARTLEY
; ADDED SOME NEW COREVALS
;<HARTLEY>LISP.MAC;5 24-JUL-75 18:02:08 EDIT BY HARTLEY
; MADE FRPLACA, FRPLACD, GETTOPVAL, SETTOPVAL, SETPROPLIST, SUBRS
;<HARTLEY>LISP.MAC;4 24-JUL-75 02:46:20 EDIT BY HARTLEY
; PUT IN NEW OPCODE (ALNCAL) AND NEW COREVALS FOR NEW COMPILER
;<NEWLISP>LISP.MAC;20 23-JUL-75 16:47:19 EDIT BY LEWIS
; change READP to look at the terminal table for the EOL char.
;<LEWIS>LISP.MAC;7 30-JUN-75 17:24:42 EDIT BY LEWIS
; ALSO ADDED A FIX FOR ALICE
; ADDED INSTANT INTERRUPTS THAT JUST SET A VARIABLE.
;<LEWIS>LISP.MAC;2 27-JUN-75 14:35:46 EDIT BY LEWIS
; FIXED A PROBLEM WITH ENABLE/DISABLE INTERRUPT CHARS.
;<LEWIS>LISP.MAC;2 25-JUN-75 12:02:09 EDIT BY LEWIS
; FIX SPACES TO ALWAYS PRINT THE SPACES.
;<LEWIS>LISP.MAC;6 22-JUN-75 20:07:32 EDIT BY LEWIS
; MAKE PRIN3 AND PRIN4 LIKE PRIN1 AND PRIN2 BUT NOT INCREMENT POSITION
;<LEWIS>LISP.MAC;13 19-JUN-75 12:38:35 EDIT BY LEWIS
; ADDED IEQP AND FIXED TTY POSITION WHEN ECHO IS OFF
;<LEWIS>LISP.MAC;9 18-JUN-75 15:05:37 EDIT BY LEWIS
; PUT IN DRIBBLE AND PRIN3
;<DLISP>LISP.MAC;84 18-JUN-75 02:51:36 EDIT BY HARTLEY
;<DLISP>LISP.MAC;83 17-JUN-75 02:09:59 EDIT BY HARTLEY
;<DLISP>LISP.MAC;81 16-JUN-75 23:45:02 EDIT BY HARTLEY
;<DLISP>LISP.MAC;78 14-JUN-75 03:10:31 EDIT BY HARTLEY
;<DLISP>LISP.MAC;77 12-JUN-75 11:05:05 EDIT BY LEWIS
; fix bug with accessing the read blip
;<DLISP>LISP.MAC;75 12-JUN-75 03:43:14 EDIT BY HARTLEY
;<DLISP>LISP.MAC;72 12-JUN-75 02:31:48 EDIT BY HARTLEY
;<DLISP>LISP.MAC;71 10-JUN-75 17:16:49 EDIT BY HARTLEY
;<DLISP>LISP.MAC;70 6-JUN-75 03:25:02 EDIT BY HARTLEY
;FIX FLUSH OF BASIC FRAME
;<DLISP>LISP.MAC;68 4-JUN-75 04:14:15 EDIT BY HARTLEY
; BEGIN TO FIX STACK OVERFLOW TO PERMIT BREAKS
;<DLISP>LISP.MAC;67 28-MAY-75 23:32:04 EDIT BY HARTLEY
;FIX BUG IN BLKAPPLY* WHEN FN NOT IN BLOCK
;<NEWLISP>LISP.MAC;8 20-MAY-75 19:59:26 EDIT BY LEWIS
; FIX BAD ATOM DEF OF "READMACROS"
;<NEWLISP>LISP.MAC;7 16-MAY-75 00:50:24 EDIT BY LEWIS
; FIX BUG IN PRINTING USER DATA TYPES
;<DLISP>LISP.MAC;62 15-MAY-75 18:09:42 EDIT BY HARTLEY
;<DLISP>LISP.MAC;61 14-MAY-75 22:41:48 EDIT BY LEWIS
; ADD PRINTING OF USER DATA TYPES.
;<DLISP>LISP.MAC;56 14-MAY-75 00:17:42 EDIT BY HARTLEY
;<DLISP>LISP.MAC;54 8-MAY-75 01:03:16 EDIT BY HARTLEY
;<DLISP>LISP.MAC;53 7-MAY-75 01:54:20 EDIT BY HARTLEY
; FIX BUG IN APPLY/EVAL OF FUNARG
;<DLISP>LISP.MAC;52 6-MAY-75 00:14:26 EDIT BY HARTLEY
; FIX BAD CHCON1 BUG WHEREIN STACK GOT FOULED
;<DLISP>LISP.MAC;51 2-MAY-75 21:14:35 EDIT BY LEWIS
; fix bug in NALLOC at GCUSER where it returned to wrong place
;<DLISP>LISP.MAC;45 1-MAY-75 03:28:46 EDIT BY HARTLEY
;<DLISP>LISP.MAC;44 30-APR-75 02:37:05 EDIT BY HARTLEY
; FIX BUG IN ENVEVAL
;<DLISP>LISP.MAC;43 30-APR-75 00:43:25 EDIT BY HARTLEY
; FIX ALL ASSUMPTIONS THAT LEFT HALF OF SUBR BINDING = 0 - IT AINT
;<DLISP>LISP.MAC;42 29-APR-75 13:27:44 EDIT BY LEWIS
; fixed typo in the definition of the atom USERCONS
;<DLISP>LISP.MAC;39 26-APR-75 03:26:25 EDIT BY HARTLEY
; ADD ENVAPPLY
;<DLISP>LISP.MAC;37 26-APR-75 01:29:13 EDIT BY HARTLEY
; MAKE ARGTYPE WORK FOR FUNARGS, FIX COMPILED APPLY* OF FUNARG
;<DLISP>LISP.MAC;36 23-APR-75 03:10:38 EDIT BY HARTLEY
; FIX STKSCAN
;<HARTLEY>LISP.MAC;1 21-APR-75 17:47:17 EDIT BY HARTLEY
; FIX SETN BUG
;<DLISP>LISP.MAC;33 19-APR-75 01:00:02 EDIT BY HARTLEY
; FIX OPNJFN() TO BE ERROR, APPLY* FUNARG
;<DLISP>LISP.MAC;32 18-APR-75 20:40:32 EDIT BY LEWIS
; MAKE PEEKC AND PRIN1 HAVE 2 ARGS
;<DLISP>LISP.MAC;28 10-APR-75 02:51:54 EDIT BY HARTLEY
; FIX STACK OVERFLOW AND CATCH RETFROM TOP
;<DLISP>LISP.MAC;27 9-APR-75 01:45:06 EDIT BY HARTLEY
;<DLISP>LISP.MAC;26 5-APR-75 15:46:47 EDIT BY HARTLEY
;<DLISP>LISP.MAC;25 26-MAR-75 00:43:26 EDIT BY LEWIS
; turn on bit 0 of aicc so 1st user interrupt char will work
;<DLISP>LISP.MAC;22 23-MAR-75 23:35:52 EDIT BY HARTLEY
;<DLISP>LISP.MAC;21 15-MAR-75 17:26:11 EDIT BY LEWIS
; RSTRING IS SUPPOSE TO TAKE 2 ARGS, NOT 1 (SECOND IS A READTABLE)
;<DLISP>LISP.MAC;20 10-MAR-75 03:12:53 EDIT BY HARTLEY
;<DLISP>LISP.MAC;19 7-MAR-75 04:06:30 EDIT BY HARTLEY
;<DLISP>LISP.MAC;17 12-FEB-75 12:24:06 EDIT BY HARTLEY
;<DLISP>LISP.MAC;13 1-FEB-75 01:58:38 EDIT BY HARTLEY
;ADD SETBLIPVAL AND IMPROVE BLIPEVAL
;<DLISP>LISP.MAC;12 31-JAN-75 20:10:24 EDIT BY HARTLEY
; FANCY BACKTRACE WITH *FN* ETC.
;<DLISP>LISP.MAC;11 11-DEC-74 16:01:37 EDIT BY LEWIS
; FIX A READMACRO PROBLEM WITH "]", EG, INPUTING 'A]
;<DLISP>LISP.MAC;10 9-DEC-74 15:29:19 EDIT BY LEWIS
; MAKE ELT TAKE SWAPPED ARRAYS
;<DLISP>LISP.MAC;9 5-DEC-74 01:05:22 EDIT BY HARTLEY
;ADD STKNTHNAME
;<DLISP>LISP.MAC;6 4-DEC-74 03:29:23 EDIT BY HARTLEY
;<DLISP>LISP.MAC;5 3-DEC-74 03:07:37 EDIT BY HARTLEY
;ADD FUNARG
;<DLISP>LISP.MAC;4 3-DEC-74 02:40:10 EDIT BY HARTLEY
; FIX EVALA, MAKE STKARG,SETSTKARG,ETC. TAKE NAME AS WELL
;AS NUMBER, SPEED UP REBIND
;<DLISP>LISP.MAC;3 30-NOV-74 15:01:45 EDIT BY LEWIS
; FIX INREADMACROP, SETREADMACROP. AND CHANGE ↑A MESSAGES TO NEW FORM.
;<NEWLISP>LISP.MAC;5 25-NOV-74 12:41:21 EDIT BY LEWIS
; MAKE FILE NAMES ALWAYS HAVE DIRECTORY.
;<NEWLISP>LISP.MAC;3 24-NOV-74 02:14:17 EDIT BY HARTLEY
; FIX WTRP FOR KI-10
;<NEWLISP>LISP.MAC;2 23-NOV-74 03:42:45 EDIT BY HARTLEY
;FIX CONTROL-H
;<DLISP>NNLISP.MAC;64 17-NOV-74 05:21:53 EDIT BY LEWIS
; FIX AN ERRORSTRING TYPO
;<DLISP>NNLISP.MAC;61 16-NOV-74 23:39:49 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;58 16-NOV-74 19:10:57 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;56 16-NOV-74 16:14:23 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;55 16-NOV-74 05:52:35 EDIT BY HARTLEY
; ADD COPYSTK
;<DLISP>NNLISP.MAC;54 16-NOV-74 03:40:09 EDIT BY LEWIS
; FIX COND AGAIN, ADD ERRORSTRING, FIX MAKESYS/RAISE STUFF
;<DLISP>NNLISP.MAC;52 16-NOV-74 00:31:47 EDIT BY LEWIS
; REINSTALL INREADMACROP SETREADMACROFLG
;<DLISP>NNLISP.MAC;49 15-NOV-74 23:49:08 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;48 15-NOV-74 23:03:55 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;47 11-NOV-74 02:36:37 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;45 9-NOV-74 01:32:35 EDIT BY HARTLEY
;FIX INTERACTION OF NON-LOCAL GO AND SWAPPER
;<DLISP>NNLISP.MAC;44 8-NOV-74 19:45:44 EDIT BY LEWIS
; USE INTERNAL CALL TO APPLY* WHEN CALLING READMACRO FUNCTIONS.
;<DLISP>NNLISP.MAC;43 6-NOV-74 02:00:30 EDIT BY LEWIS
;<DLISP>NNLISP.MAC;42 5-NOV-74 20:21:32 EDIT BY LEWIS
; FIXED PPOBLEM WITH LREAD BEING SET WHEN ENTERING MKATM
;<DLISP>NNLISP.MAC;41 5-NOV-74 15:03:09 EDIT BY LEWIS
; CHANGE INFIX MACROS TO GET A NIL LIST IF AT THE TOPLEVEL
;<DLISP>NNLISP.MAC;39 5-NOV-74 01:41:45 EDIT BY LEWIS
; FIX READMACROS TO SAVE AND RESTORE FRX AND RDAX
;<DLISP>NNLISP.MAC;38 4-NOV-74 13:30:24 EDIT BY LEWIS
; ADD "FIRST", "ALONE", AND "IMMEDIATE" TYPE READMACROS
; MAKE INFIX MACROS WORK WHEN READ AT TOPLEVEL
;<DLISP>NNLISP.MAC;37 30-OCT-74 17:40:43 EDIT BY LEWIS
; RESTORE BACKUP CHAR WHEN CHANGING READING OF STRINGS.
;<DLISP>NNLISP.MAC;35 29-OCT-74 20:13:43 EDIT BY HARTLEY
; MERGE CHANGES FROM OCT 15 TO PRESENT
;<DLISP>LISP.MAC;13 27-OCT-74 03:26:02 EDIT BY HARTLEY
;<DLISP>LISP.MAC;10 24-OCT-74 21:45:09 EDIT BY HARTLEY
;<DLISP>LISP.MAC;5 22-OCT-74 16:55:54 EDIT BY HARTLEY
;<DLISP>LISP.MAC;4 19-OCT-74 03:42:11 EDIT BY HARTLEY
;<DLISP>LISP.MAC;3 18-OCT-74 20:16:10 EDIT BY HARTLEY
;<DLISP>LISP.MAC;2 18-OCT-74 04:59:18 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;21 15-OCT-74 00:51:21 EDIT BY HARTLEY
; FIX PPLOOK FOR SPECVARS IN BLOCKS
;<DLISP>NNLISP.MAC;20 11-OCT-74 23:26:37 EDIT BY LEWIS
; FIX INTERACTIONS BETWEEN CONTROL/RAISE AND READMACROS
;<DLISP>NNLISP.MAC;19 11-OCT-74 14:28:31 EDIT BY LEWIS
; fix inter.raise problm with control=T, & control(T) always ret.NIL.
;<DLISP>NNLISP.MAC;18 10-OCT-74 12:14:51 EDIT BY LEWIS
;<LEWIS>NNLISP.MAC;1 10-OCT-74 12:06:52 EDIT BY LEWIS
; MAKE ↑V ALSO WORK WITH LOWER CASE LETTERS
; TAKE OUT 0/1 FROM CONTROL AND MAKE SYSOUT CLEAR, NOT CLOSE FILE TABLE
;FIX BKLINBUF CHAR COUNT BUG
; PUT RAISE ON TERM.TBL, MAKE MODE T BE 0, DEFINE T AS "INTERNAL RAISE"
;<DLISP>NNLISP.MAC;16 8-OCT-74 14:35:55 EDIT BY LEWIS
; FIX WAKEUP PROBLEM IN PEEKC
;<DLISP>NNLISP.MAC;15 7-OCT-74 17:56:02 EDIT BY LEWIS
;<DLISP>NNLISP.MAC;13 7-OCT-74 17:02:58 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;12 6-OCT-74 14:41:27 EDIT BY LEWIS
; MAKE CONTROL TAKE TERM.TABLE AND ADD ECHOMODE
;<DLISP>NNLISP.MAC;11 6-OCT-74 11:38:45 EDIT BY LEWIS
; added extra messages to ↑A and added 2nd arg flag to readp
;<DLISP>NNLISP.MAC;10 4-OCT-74 02:54:04 EDIT BY LEWIS
; SEPERATE EDIT AND CTL.CH.ECHO FROM READTABLES INTO TERMINAL TABLES
;<DLISP>NNLISP.MAC;9 24-SEP-74 20:16:18 EDIT BY LEWIS
;<DLISP>NNLISP.MAC;8 23-SEP-74 20:28:05 EDIT BY LEWIS
; MAKE SETBRK GIVE ERROR IF 1ST ARG NOT LIST
;<DLISP>NNLISP.MAC;6 23-SEP-74 19:27:55 EDIT BY LEWIS
; FIX BAD FLTPT. OUTPUT FORMAT BUG.
;<DLISP>NNLISP.MAC;5 19-SEP-74 21:29:13 EDIT BY LEWIS
; FIX NCHARS, CHCON, UNPACK, NTHCHAR (AND IPRE2) TO TAKE A READTABLE
;<DLISP>NNLISP.MAC;4 19-SEP-74 09:49:45 EDIT BY LEWIS
; FIX INFIX MACROS
;<DLISP>NNLISP.MAC;3 16-SEP-74 07:16:53 EDIT BY LEWIS
; READTABLE FNS USE ORIG INSTEAD OF RESET TO REF. PRISTINE TABLE.
;<DLISP>NNLISP.MAC;2 16-SEP-74 05:27:35 EDIT BY LEWIS
; ADD RESETREADTABLE AND COPYREADTABLE, CHANGE SOME OTHER RDTBL FNS
;<LEWIS>NNLISP.MAC;3 14-SEP-74 05:48:44 EDIT BY LEWIS
; INSTALL READTABLE ARGS IN I/O
;<HARTLEY>NNLISP.MAC;29 3-SEP-74 03:46:01 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;27 1-SEP-74 04:21:41 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;25 30-AUG-74 17:26:42 EDIT BY HARTLEY
; FIX INTFX, SUBRP, AND BLKENT
;<HARTLEY>NNLISP.MAC;21 27-AUG-74 22:23:37 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;16 25-AUG-74 18:09:50 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;13 24-AUG-74 20:33:28 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;9 21-AUG-74 01:36:02 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;8 20-AUG-74 18:39:37 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;7 20-AUG-74 03:16:26 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;5 17-AUG-74 04:03:30 EDIT BY HARTLEY
;<FLIP>LISP.MAC;20 4-AUG-74 15:30:37 EDIT BY LEWIS
; CHANGED FORMAT OF SWAPPER ERROR MESSAGES
;<FLIP>LISP.MAC;18 24-JUL-74 18:03:28 EDIT BY LEWIS
; PUT IN SWAPPER
;<FLIP>LISP.MAC;7 16-JUL-74 07:19:06 EDIT BY LEWIS
; ADDED ALICE'S LATEST FIXES
;<FLIP>LISP.MAC;5 13-JUL-74 23:56:30 EDIT BY LEWIS
; MORE ENABLECHAR AND DISABLECHAR
;<FLIP>LISP.MAC;4 9-JUL-74 19:57:58 EDIT BY LEWIS
; ADDED COREVALS FOR FAST FN-OPENR/CLOSER FNS
;<FLIP>LISP.MAC;3 9-JUL-74 01:18:38 EDIT BY LEWIS
; ADDED FN-OPENR/CLOSER FNS
;<FLIP>LISP.MAC;2 3-JUL-74 22:03:51 EDIT BY LEWIS
;<LEWIS>LISP.MAC;51 27-JUN-74 05:39:27 EDIT BY LEWIS
;<LEWIS>LISP.MAC;49 25-JUN-74 19:43:18 EDIT BY LEWIS
; MERGED WITH SPAG.
;<LEWIS>LISP.MAC;1 13-JUN-74 06:43:51 EDIT BY LEWIS
; FIXED BUG IN RSTRING DUE TO READTABLES
;<LEWIS>LISP.MAC;1 10-JUN-74 10:53:18 EDIT BY LEWIS
; FIXED BUG IN UNBUFFERED READ
;<LEWIS>LISP.MAC;1 9-JUN-74 00:35:39 EDIT BY LEWIS
; FIXED READP FOR READING STRINGS
;<LEWIS>LISP.MAC;4 8-JUN-74 05:27:34 EDIT BY LEWIS
; FIXED BACKTRACE FOR WARREN
;<LEWIS>LISP.MAC;1 7-JUN-74 20:51:15 EDIT BY LEWIS
; FIXED STKNTH FOR WARREN
;<LEWIS>LISP.MAC;2 6-JUN-74 04:15:50 EDIT BY LEWIS
; FIXED BUG IN GNC AND ADDED READING FROM STRINGS
;<LEWIS>LISP.MAC;8 5-JUN-74 04:23:23 EDIT BY LEWIS
; FIXED SQBRK AND ADDED USER INTERRUPT CHARACTERS
;<NEWLISP>LISP.MAC;3 3-JUN-74 19:53:20 EDIT BY LEWIS
; FIX ESCAPE ALWAYS RETURNING NIL PROBLEM
;<GOODWIN>LISP.MAC;20 24-MAY-74 07:57:04 EDIT BY GOODWIN
;Fixed FTRP1 to relocate right to find freevar vector.
;<GOODWIN>FIE.;100018 3-MAY-74 04:03:36 EDIT BY GOODWIN
; - INSTALLING SWAPPER, FLUSH E+S DISPLAY SWITCHED CODE. JWG
;<FLIP>LISP.MAC;82 23-APR-74 15:17:47 EDIT BY LEWIS
;<FLIP>LISP.MAC;81 7-APR-74 00:45:13 EDIT BY LEWIS
;INSERTED ALICE'S CHANGES FOR PRXFLG
;<FLIP>LISP.MAC;80 31-MAR-74 14:25:15 EDIT BY LEWIS
;<FLIP>LISP.MAC;2 18-MAR-74 21:04:05 EDIT BY LEWIS
;<FLIP>LISP.MAC;1 19-FEB-74 00:25:30 EDIT BY LEWIS
;<FLIP>LISP.MAC;5 18-FEB-74 01:53:47 EDIT BY LEWIS
;<FLIP>LISP.MAC;3 17-FEB-74 19:46:52 EDIT BY LEWIS
;<FLIP>LISP.MAC;3 17-FEB-74 03:40:14 EDIT BY LEWIS
;<FLIP>LISP.MAC;3 11-FEB-74 18:02:52 EDIT BY LEWIS
;<HARTLEY>LISP.MAC;24 6-FEB-74 19:19:16 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC;21 6-FEB-74 02:16:23 EDIT BY HARTLEY
;<FLIP>LISP.MAC;3 5-FEB-74 08:51:52 EDIT BY LEWIS
;<LEWIS>LISP.MAC;1 5-FEB-74 07:08:47 EDIT BY LEWIS
;<FLIP>LISP.MAC;2 3-FEB-74 09:40:53 EDIT BY LEWIS
;<HARTLEY>LISP.MAC;16 1-FEB-74 21:02:51 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC;8 31-JAN-74 03:16:13 EDIT BY HARTLEY
;<FLIP>LISP.MAC;8 30-JAN-74 02:07:36 EDIT BY LEWIS
TITLE LISP
;20 AUG 74, 2006:
;SYSTEM SWITCH, 0 FOR TENEX, 1 FOR 10/50
IFNDEF TEN50,<TEN50==0>
IFN TEN50,<
EXTERN CIO,FINIT,INFIL,OUTFIL,RFNM,CLOSEF
EXTERN JOBSYM,JOBSA,JOBREL,JOBDDT,JOBREN,JOBOPC,JOBFF
>
IF1,<PURGE CDR>
SYSDAT=777 ;DATE OF CREATION - FOR SYSIN CHECK
SEARCH STENEX
;PARAMETERS
NPM==1000 ;MAX NUMBER OF PAGES IN SYSTEM
NPS==1000 ;PAGE SIZE
LPS==11 ;LOG OF PAGE SIZE
MPS==NPS-1 ;PAGE MASK
;INITIAL ALLOCATIONS (NUMBER OF PAGES)
NLW==4 ;LIST WORDS
NAT==6 ;ATOMS
NHT==20 ;ATOM HAST TABLE - MUST BE POWER OF 2
MAXNHT==100 ;MAX # PAGES HASH TABLE CAN GROW TO
NFN==1 ;FLOATING NUMBERS
NNM==1 ;INTEGER NUMBERS
NPN==4 ;PNAME STRINGS
NST==1 ;REGULAR STRINGS
NSP==1 ;STRING POINTERS
NAR==3 ;ARRAYS
NHDL==1 ;HANDLES
NSTKP==1 ;STACK POINTERS
;INITIAL SIZES
NCP==12000 ;CONTROL STACK
NPP==10000 ;PARAMETER STACK
NIP==24 ;INTERRUPT LEVEL STACK
NREDCP==276 ;EMERGENCY STACK - IS SUBTRACTED FROM NCP
NREDPP==276 ;EMERGENCY STACK
NFILES==20
NFRKS==4 ;NUMBER OF FORKS FOR SHADOW SPACE
MFRKS==3 ;MASK FOR ABOVE
;AC ASSIGNMENTS
CP=17 ;CONTROL STACK
PP=16 ;PARAMETER STACK
BR=15 ;SWAPPING BASE REG.
VP=14 ;PTR TO ARGS OF RUNNING FN(ONE LESS)
FF=13 ;BLOCK COMPILER FREE VAR PTR
TP=12 ;FOR UUO DECODE
TF=11 ;TEMP FLAGS
FX=10 ;FILE INDEX
F=0 ;FLAGS
;MAGIC MARKERS ON STACKS
NMBLIP==21 ;ON CP - NMBLIP,,# NUMS FOLLOWING
EVBLIP==100 ;ON PP - EVBLIP,,FORM FOR EVAL
APBLIP==10 ;ON PP - APBLIP,,ARGLIST FOR APPLY
PRBLIP==40 ;ON PP, PRBLIP,,LIST OF FORMS FOR PROGN
AVBLIP==200 ;ON PP AVBLIP,,ARG VALUE FOR PARTIAL EVAL
FNBLIP==50 ;ON PP FNBLIP(+TYP),,FN NAME FOR PARTIAL EVAL
STKHOL==707 ;ON PP OR CP - STKHOL,,# SLOTS AVAIL
STKEND==717 ;ON PP OR CP - STKEND,,NEXT STK BLOCK OR 0
;MISC
EOL=37 ;END OF LINE CHARACTER
ESC=45 ;% - ESCAPE CHAR, I.E. ONE SHOT QUOTE
NCHRS=1000 ;SIZE OF CHARACTER PSEUDO-SPACE
ACHAR==400 ;ADDRESS OF FIRST CHAR
MSN==6000 ;SIZE OF SMALL NUMBER PSEUDO-SPACE
ASZ=MSN/2+NCHRS ;SMALL NUMBER ZERO
MINWPP==20 ;CONS - MIN FREE WORDS FOR PAGE TO RECEIVE NEW LIST
NATMC==176 ;MAX NUMBER OR CHARS IN ATOM
;FLAGS - RIGHT HALF ARE TEMPORARY
NEGFLG==1 ;ATOM CONSTRUCTER - MINUS SIGN SEEN
LETFLG==2 ; - LETTER SEEN
QFLG==4 ; - Q WAS LAST CHAR
DIGFLG==10 ; - DIGIT SEEN
FLTFLG==20 ; - FLOATING INDICATION
RQTFLG==40 ;DOUBLEQUOTED ATOM
LREAD==100 ;RATOM - LISP READ
RATFLG==200 ;- IN RATOM OR RSTRING
CHFLG==400 ; - CHARACTER PACKED
RMFLG==1000 ;READ BLIP ON STACK
ESCFLG==2000 ;ESCAPE FLAG - LINE BUFFER
GCHDQF==4000 ;WITHIN DOUBLE-QUOTE, LINE BUFFER
RDMFLG==10000 ; - IN A READMACRO
ERQFLG==20000 ;KEYBOARD ERROR REQUEST PENDING
PMCFLG==40000 ;PRINT MARGIN CHECK FLAG
INTFLG==100000 ;KEYBOARD INTERRUPT REQUEST
SEPFLG==200000 ;SEPARATOR PRECEEDED ATOM
GCFLG==400000 ;DOING GC
; - LEFT HALF ARE PERMANENT
PNEGF==1 ;PRINT NEG NUMBER WITH SIGN
LBFFLG==2 ;NO LINEBUFFERING
RASFLG==4 ;INTERNAL INPUT RAISE FLAG
GCF==10 ;TEMP FLAG FOR GC
GCMF==20 ;GC MOVE FLAG-ANY PAGES MOVING
GCCF==40 ;GC COMPACT FLAG-ANY TYPE COMPACTING
GCPF==100 ;GC CHANGE POINTER FLAG-GEN TYPE COMPACTING
;...OR PAGES SHUFFLING
STKFLG==200 ;STACK HAS SKIP BLIP
CNSFLG==400 ;FRECNT=FREBRK
NEGPLF==1000 ;NEGATIVE PRINTLEVEL FLAG
PRPFLG==2000 ;JUST PRINTED RIGHT PAREN
NCRFLG==4000 ;NO EOL ON CLOSING PAREN IN READ
BKFLG==10000 ;PUTTING STRING IN LINE BUFFER
NACFLG==20000 ;DISALLOW NON-ATOMIC CAR
EVLFLG==40000 ;...BUT PERMIT BELOW FIRST LEVEL
HDLFLG==100000 ;FOR GC - HANDLE CHASE IN PROGRESS
PDQFLG==200000 ;PRINT ESCAPES IN ATOMS AND STRINGS
PRXFLG==400000 ;USE RADIX FOR NUMBERS
;MACROS AND DEFS
OPDEF CALL [PUSHJ CP,0]
OPDEF RET [POPJ CP,0]
;CAR AND CDR
;A IS DESTINATION ACCUMULATOR
;Y IS SOURCE, AC OR STORAGE
DEFINE CARA (A,Y)
< BB=0
IFG Y,<
IFL Y-20,<
BB=-1
HRRZ A,0(Y)>>
IFE BB,<
HRRZ A,@Y>>
DEFINE CDRA (A,Y)
< BB=0
IFG Y,<
IFL Y-20,<
BB=-1
HLRZ A,0(Y)>>
IFE BB,<
HLRZ A,@Y>>
;TYPE QUOTED STRING
DEFINE TYPEQ (A)
< TMSG [SIXBIT @A/@]>
;UNSTEP BYTE POINTER
DEFINE UBP (A)
< BB==0
IFG A,<
IFL A-20,<
BB=-1
ADD A,[7B5]
SKIPG A
ADD A,[35B5-1]>>
IFE BB,<
EXCH 1,A
UBP 1
EXCH 1,A>>
;STRING POINTER TO BYTE POINTER CONVERSION
DEFINE SBPC (C,B)
< MOVE C,0(B)
IFE B-C,<PUSH CP,C>
TLZ C,777770
IDIVI C,5
HLL C,CBTAB-1(C+1)
IFE B-C,<POP CP,C+1>
IFN B-C,<MOVE C+1,0(B)>
LSH C+1,-↑D21>
;UNBOXED STRING POINTER CONVERSION
DEFINE USBPC (C,B)
< MOVE C,B
IFE B-C,<PUSH CP,C>
TLZ C,777770
IDIVI C,5
HLL C,CBTAB-1(C+1)
IFE B-C,<POP CP,C+1>
IFN B-C,<MOVE C+1,B>
LSH C+1,-↑D21>
;DEFINE STORAGE WORD OR BLOCK
DEFINE U (A,B)
< A=BEGTMP+ZZ
IFB <B>,<ZZ=ZZ+1>
IFNB <B>,<ZZ=ZZ+B>>
ZZ=0
BEGTMP==31000
;LOAD TYPE NUMBER INTO AC
;A-DESTINATION AC, C-SOURCE AC IF SUPPLIED
DEFINE LDT (A,C)
< IFNB <C>,<
HRRZ A,C>
LSH A,-LPS
HRRZ A,TYPTAB(A)>
;SKIP TYPE EQUAL, NOT EQUAL
;A-SOURCE AC, B-TYPE
DEFINE STE (A,B)
< PSTE A,B'T>
DEFINE STN (A,B)
< PSTN A,B'T>
;FUNCTION CALL FROM HAND CODE
DEFINE LCALL (FN,NA)
< MOVEI 1,NA
MOVE 2,FN
PUSHJ CP,EFNCAL
>
;PUSH NUMBER(S)
DEFINE PUSHN (A,B)
<IFNB <B>,< PUSH CP,[XWD NMBLIP,B]>
IFB <B>,< PUSH CP,[XWD NMBLIP,1]>
PUSH CP,A
>
DEFINE POPN (A)
< POP CP,A
SUB CP,BHC+1
>
;ERROR CALL
;LOC IS LOCATION TO CONTINUE
;N IS ERROR NUMBER
;ERROR1 SUPPLIES VALUE IN AC1
DEFINE ERROR1 (N,LOC)
< PERR <N&17>,LOC+<N&60>B24>
;ERROR0 SUPPLIES NO VALUE
DEFINE ERROR0 (N,LOC)
< PERR0 <N&17>,LOC+<N&60>B24>
;TERMINAL INTERRUPT STUFF
IFN TEN50,<
DEFINE SETICH
< MOVEI 1,20000
TTCALL 6,1 ;READ LINE STATUS
HRLI 1,400020 ;TELMOD (400000) + TELISP (20) BITS
TTCALL 7,1 ;SET LINE STATUS
>
DEFINE CLRICH
< MOVEI 1,20000
TTCALL 7,1
>
;VARIOUS SYSTEM OPS
OPDEF TIME [CALLI 1,23] ;READ CLOCK IN MS
OPDEF CLRTIB [TTCALL 11,0] ;CLEAR TTY IN BUF
OPDEF CLRTOB [TTCALL 12,0] ;CLEAR OUTPUT BUFFER
OPDEF SKIBNE [TTCALL 13,0] ;SKIPE IN IN BUF NOT EMPTY
OPDEF BOUT [PUSHJ CP,CIO] ;BYTE OUT
OPDEF BIN [PUSHJ CP,CIO] ;BYTE IN
OPDEF CORE [CALLI 2,11] ;SET CORE LIMIT
OPDEF HALTF [CALLI 12]
DEFINE GETJRT
< MOVEI 1,0 ;INDICATE CURRENT JOB
CALLI 1,27 ;GET JOB RUN TIME
>
> ;CLOSES IFN TEN50
IFE TEN50,<
JOBSA==120
DEFINE SETICH
< CALL SETINT
>
DEFINE CLRICH
< MOVE 7,CTCTP ;DEASSIGN TERMINAL INTERRUPT CODES
HLRZ 1,0(7)
TRNN 1,400000 ;MAKE SURE IT'S REALLY THERE
DTI
AOBJN 7,.-3
>
DEFINE GETJRT
< MOVEI 1,400000 ;JUST THIS FORK
RUNTM ;GET JOB RUN TIME
>
DEFINE CLRTIB
< MOVEI 1,100
CFIBF>
DEFINE CLRTOB
< MOVEI 1,101
CFOBF>
DEFINE SKIBNE
< MOVEI 1,100
SIBE
SKIPA>
>
;UUO DEFINITIONS
OPDEF TMSG [1B8]
OPDEF TCH [2B8]
OPDEF PERR [3B8]
OPDEF PSTE [4B8]
OPDEF PSTN [5B8]
OPDEF PSTB [6B8]
OPDEF PSTNB [7B8]
HCCALV==10
OPDEF HCCAL0 [10B8]
OPDEF HCCAL1 [11B8]
OPDEF HCCAL2 [12B8]
OPDEF HCCAL3 [13B8]
OPDEF EXCAL [14B8]
OPDEF CCALL [15B8]
OPDEF PBIND [16B8]
OPDEF PBIND2 [17B8]
OPDEF PIBOX [20B8]
OPDEF PIUNBX [21B8]
OPDEF PSETN [22B8]
OPDEF PERR0 [23B8]
OPDEF LNCALL [24B8]
OPDEF LNCAL2 [25B8]
OPDEF CKUDT [26B8]
OPDEF PSTEI [27B8]
OPDEF PSTNI [30B8]
OPDEF SBCAL [31B8]
OPDEF ACCALL [32B8]
OPDEF ALNCAL [33B8]
;GLOBAL STORAGE
U TYPTAB,NPM ;TABLE OF DATA TYPES AND STATUS
U ATOMHT,MAXNHT+1 ;TABLE OF HASH TABLE PAGES
U NHP ;CURRENT # HASH TABLE PAGES
U IBOXCN ;INTEGER BOX COUNT
U FBOXCN ;FLOATING BOX COUNT
U ENDCOR ;END OF ASSIGNED CORE
U NEWCNS ;CONS - LOWEST PAGE WITH SOME FREE WORDS
U LSTCNS ; - LAST CONS
U CNSCNT ; - CONS COUNT
U FREBRK ; - BREAK WHEN FREBRK=FRECNT
U CMINWP ;CONTAINS MINWPP FOR CONS
U OFRECT
U MAXATL ;MAX NUMBER OF CHARS IN ATOM (USER SET)
U LINSIZ ;MAX NUMBER OF CHARS PER OUTPUT LINE
U URADIX ;CURRENT OUTPUT RADIX
U ESCONF ;ESCAPE CHAR FLAG - 0=OFF -1=ON
U RMONF ;READMACRO FLAG - 0=OFF -1=ON
;ATOMS
U KNIL
U KT
U KNOB
U KLAM
U KNLA
U KPROG
U KPER
U KFNARG
U KINPUT
U KOUTPUT
U KORIG
U KSYSHS
U KEVAL
U KLPT
U KRLBLK
U KFORM
U KTAIL
U KFN
U KAVAL
U KPRINT ;FUNCTIONS CALLED INTERNALLY
U KREADX
U KAPPLY
U KAPP.
U KEVLQT
U KFAULT
U KFALTA
U KERRX
U KESGAG
U KERSET
U KINT
U KSTVAL
U CURRDT ;READTABLES
U SYSRDT
U CURRT2
U SYSRT2
U PRVIRT
U PRVORT
U BSTAB
U PBTAB
U TTYTBL ;CURRENT TERMINAL TABLE
U KPRXFL ;RADIX FLG FOR INTERNAL PRINT
U HLDMSG ;USER HEARLD MESSAGE
U KPRGLM
U GCMES2
U GCMESF ;MAYBE USERS GC MESSAGE
NKCELL==GCMESF+1-KNIL ;NUMBER OF K-ATOM CELLS
U FILEA,NFILES+1 ;LAST CHAR READ,,FILE NAME ATOM
U FILEN,NFILES ;STATUS FLAGS,,FILE NUMBER
U FCHAR,NFILES+1 ;FILE DATA- FLAGS,,ONE CHARACTER BUFFER
U CHPOS,NFILES ; - PAGE POSN,,LINE POSN
; THE NFILES+1 IS TO LEAVE ROOM FOR STRING INPUT
U FRX ;CURRENT READ AND PRINT FILE INDEX
U FPX
U LOGTOD ;LOGIN TIME-OF-DAY
U LOGRT ;LOGIN RUN-TIME
U GCRT ;GARBAGE COLLECTOR RUNTIME
U FNCALL ;XCT 1(2) OR CALL XBREAK
U FR ;STANDARD READ AND PRINT FILES
U FP
U ICP ;INITIAL STACK VALUES
U ICPC ;CONTROL STACK CONSTANT
U IPP
U IPPC ;PARAMETER STACK CONSTANT
U IREDPP
U IREDCP
U BGNCOR ;BEGINNING OF DATA SPACE
;ABSOLUTE ASSEMBLY OF PAGE 0. BOOTSTRAP TO GET IN THE BOOTSTRAP TO
;GET IN REST OF WORLD, & SOME DATA NEEDED BY SECOND BOOTSTRAP SUCH AS
;SYSDAT, BUFFER FOR FORKHANDLES.
LOC 140
BBOOT:
SKIPA
;NEXT WRD IS USED BY BOOTSTRAP TO FIND RETURN CODE FROM SYSIN
JRST SYSINR
HRLZI 1,400000 ;THIS FORK PAGE 0 (RIGHT HERE)
RMAP ;IS JFN FOR SELF
HLRZ 6,1 ;SAVE IT
MBOOT: HRLZI 1,100001 ;ENTER HERE FROM SYSDN1 AFTER MAKESYS
HRROI 2,BOOTNM
GTJFN
JRST BLOSE
HRLI 1,400000
GET
HRRZI 1,(6) ;RETRIEVE JFN FOR SELF
JRST 777000 ;GOTO BOOTSTRAP
BLOSE: HRROI 1,BLOSM
PSOUT
HALTF
;THESE MUST BE ON PAGE 0 TOO SO DIDN'T MAKE THEM LITERALS.
BLOSM: ASCIZ /CANNOT FIND <LISP>BOOT.SAV/
BOOTNM: ASCIZ /<LISP>BOOT.SAV;0/
LOC 1000-↑D48
MYJFNS: 0
MYFRKS: BLOCK 20
DADDYN: BLOCK ↑D30
DATEWD: 0 ;REALLY CALLED SYSDAT.
RELOC
;TABLE OF COREVALS FOR COMPILER
;IF THESE MOVE VARIABLE COREVALA IN COMPILER MUST BE CHANGED
COREV: EXP CP
EXP PP
EXP VP
EXP FF
EXP BR
EXP ENTERF
EXP FNCALL
EXP BHC
EXP UUARG1
EXP UUARG1
EXP UUARG1
EXP KT ;11
EXP KNIL
EXP ARRAYT
EXP BLOCKT
EXP CCODET
EXP BTABT
EXP LISTT
EXP ATOMT
EXP FLOATT
EXP FIXT
EXP SMALLT
EXP STPTT
EXP CHART
EXP PNAMT
EXP STRNGT
EXP CONS ;30
EXP IUNBOX
EXP MKN
EXP FUNBOX
EXP MKFN
EXP GUNBOX
EXP GBOX
EXP FXFLT
EXP FLTFX
EXP ASZ
EXP TYPTAB
EXP CLIST
EXP EVCC
EXP UPATM
EXP IPRE
EXP IPRE2
EXP FILEN
EXP IFSET
EXP OFSET
EXP FX
EXP FIN
EXP FOUT
EXP IOFNMP
EXP HCRET
EXP ERRSET
EXP ICPC
EXP SETINT
EXP CTCTP
EXP IPPC
EXP MKSP
EXP UNP1
EXP MKSTR1
EXP MKSTRS
EXP FILEA
EXP FCHAR
EXP CNSCNT
EXP SETMOD
EXP REBIND
EXP UNBIND
EXP EFNCAL
EXP ERR0Q ;WAS RETCAL - NO LONGER EXISTS
EXP BLKENT
EXP BLKAPP
EXP BLKAP.
EXP HCAL0Q ;FIX WHATEVER TIS IS FOR:::::::****
EXP EXCALQ
EXP CCALC
EXP FMEMB
EXP PPLOOK
EXP LINBF3
EXP IOFN
EXP GETHSH
EXP PUTHSH
EXP GCRT
EXP CFRAM
EXP NLGO
EXP NLRET
EXP CF
EXP [POINT NARSIZ,@CF,17]
EXP IBOXCN
EXP FBOXCN
EXP ENTERB
EXP SBLKNT
EXP SBCALQ
EXP ORGRDT
EXP SWAPIN
EXP HANDLT
EXP FFNOPR
EXP FFNOPA
EXP FFNOPD
EXP FFNCLR
EXP FFNCLA
EXP FFNCLD
EXP POPTAB
EXP CONSNL
EXP CONS21
EXP LIST2
EXP LIST3
EXP LIST4
EXP CONSS1
EXP ALIST
EXP ALIST2
EXP ALIST3
EXP ALIST4
EXP URET02
EXP URET01
EXP URET12
EXP URET11
EXP URET10
EXP URET22
EXP URET21
EXP URET20
EXP URET32
EXP URET31
EXP URET30
EXP URET42
EXP URET41
EXP URET40
EXP URET52
EXP URET51
EXP URET50
EXP URET62
EXP URET61
EXP URET60
EXP URET72
EXP URET71
EXP URET70
EXP SKA
EXP SKNA
EXP SKNM
EXP SKNNM
EXP SKI
EXP SKNI
EXP SKLST
EXP SKNLST
EXP SKLA
EXP SKNLA
EXP SKAR
EXP SKNAR
EXP SKSTP
EXP SKNSTP
EXP SKSTK
EXP SKNSTK
BLOCK 4 ;FOR EXPANSION
;UUO ROUTINE
POPDSP: PUSHJ CP,POPCL ;C(41)
POPCL: HLRZ TP,40
LSH TP,-↑D9
JRST @POPTAB(TP)
;ARGS TO UUO'S
U UUARG1
UUACP: POINT 4,40,12 ;BYTE POINTER TO UUO AC FIELD
;UUO DISPATCH TABLE
POPTAB: EXP UUUOQ,TMSGQ,TCHQ,ERRQ,STEQ,STNQ,STBQ,STNBQ
EXP HCAL0Q,HCAL1Q,HCAL2Q,HCAL3Q,EXCALQ,FNCALQ
EXP BINDQ,BBINDQ
EXP IBOXQ,IUBQ,SETNQ,ERR0Q,LCALQ,LCALQ2,CKTUSE
EXP STEI,STNI,SBCALQ,FNACAL,ALCALQ
REPEAT 5,<EXP UUUOQ>
UUUOQ: HRROI 1,[ASCIZ /ILLEGAL UUO/]
PSOUT
HALTF
;TABLE OF FULL WORD CONSTANTS
XX=-30
REPEAT 30,<EXP XX*1000001
XX=XX+1>
BHC: REPEAT 140,<EXP XX*1000001
XX=XX+1>
;TABLE OF 7 BIT BYTE POINTERS
POINT 7,0,-1
CBTAB: POINT 7,0,6
POINT 7,0,13
POINT 7,0,20
POINT 7,0,27
POINT 7,0,34
;UUO-CALLED ROUTINES
;MESSAGE TYPER
TMSGQ: PUSH CP,1
HRRZ 1,40 ;ADDRESS OF STRING
PUSH CP,2
MOVEI 2,1
HRLI 1,440600
MOVEM 1,UUARG1 ;BYTE POINTER TO STRING
TMSG1: ILDB 1,UUARG1
ADDI 1,40 ;CONVERT TO ASCII
CAIN 1,"$" ;$ BECOMES EOL
JRST TMSG3
CAIN 1,"/" ;SLASH TERMINATES
JRST TMSG2
TMSG4: CALL TCO
JRST TMSG1
TMSG3: MOVEI 1,EOL
JRST TMSG4
TMSG2: POP CP,2
POP CP,1
RET
;I/O TO CONTROL TELETYPE
TCO: PUSH CP,FX
MOVEI FX,1
CALL FOUT
POP CP,FX
RET
TCI: PUSH CP,FX
MOVEI FX,0
CALL FIN1 ;DON'T INVOKE LINE EDITOR
POP CP,FX
RET
EOLM: SIXBIT '$/'
;SKIP ON TYPE EQUAL TO C(E) OF UUO
STE1Q: MOVEI TP,0(1)
JRST .+3
STEQ: LDB TP,UUACP ;GET AC FIELD
HRRZ TP,0(TP) ;GET POINTER TO TEST
LSH TP,-LPS ;GET PAGE ADDRESS
HRRZ TP,TYPTAB(TP) ;GET TYPE NUMBER
CAIN TP,@40
AOS 0(CP) ;EQUAL - SKIP RETURN
RET
;SKIP TYPE NOT EQUAL
STN1Q: SKIPA TP,[1]
STNQ: LDB TP,UUACP
HRRZ TP,0(TP)
LSH TP,-LPS
HRRZ TP,TYPTAB(TP)
CAIE TP,@40
AOS 0(CP)
RET
;SKIP IF TYPE BETWEEN C(E) OF UUO AND SMALLT
;USED FOR ATOM NUMBERP AND FIXP
STBQ: LDT TP,1
CAIGE TP,@40
RET
CAIG TP,SMALLT
AOS 0(CP)
RET
;SKIP IF TYPE NOT BETWEEN C(E) OF UUO AND SMALLT
STNBQ: LDT TP,1
CAIL TP,@40
CAILE TP,SMALLT
AOS 0(CP)
RET
;ERROR IF TYPE NOT EQUAL TO RH(C(E))
;USED BY COMPILED CODE BEFORE SETING A USER DATA TYPE FIELD
CKTUSE: MOVEM 1,UUARG1 ;SAVE POINTER
LDT 1
HRRZ 2,@40
CAIN 1,-ASZ(2) ;IS TYPE CORRECT?
JRST CKUOK ;YES- RETURN
PUSH CP,40 ;NO, SAVE LOC. 40
MOVE 1,UUARG1 ;GET ARG.
ERROR1 40,.+1 ;GENERATE AN ERROR
HRRZ FF,CF
GETPPI FF,FF ;RESTORE FF
POP CP,40 ;RESTORE LOC. 40
JRST CKTUSE ;TRY AGAIN
;SKIP IF TYPE OF 1 EQUALS RH(C(E)) OF UUO
STEI: MOVEM 1,UUARG1
LDT 1
HRRZ 2,@40
CAIN 1,-ASZ(2)
AOS 0(CP)
MOVE 1,UUARG1
RET
;SKIP IF NOT EQUAL
STNI: MOVEM 1,UUARG1
LDT 1
HRRZ 2,@40
CAIE 1,-ASZ(2)
AOS 0(CP)
CKUOK: MOVE 1,UUARG1
RET
;BIND ARGS - EFF. ADDR OF UUO IS ADDRESS OF ARG NAMES AND CONSTANTS
;BYTES 9 #NAMS #CONST FRAMSIZ DEPTH
BINDQ: HRRZ 7,0(CP)
AOS 0(CP) ;RET FROM PROG FRAME TO 1 PAST BIND
MOVE 3,BINDP1
LDB 1,3
MOVEI 2,@40
JUMPE 1,BINDC
MOVN 1,1
HRLI 2,0(1)
ADDI 1,1(PP)
BINDC2: MOVE 4,0(2)
TLNN 4,-1 ;LH NON-ZERO MEANS LOCAL VAR(UNNAMED)
HRLM 4,0(1)
ADDI 1,1
AOBJN 2,BINDC2
BINDC: ILDB 1,3
JUMPE 1,BINDO
MOVN 1,1
HRLI 2,0(1)
PUSH PP,0(2) ;PUSH NAME,,CONSTANT
AOBJN 2,.-1
BINDO: ILDB 1,3 ;FRAM SIZE
ILDB 6,3 ;BINDING DEPTH
MOVE 4,KPRGLM ;HOKEY NAME FOR PROG/LAM
JSP 5,CFRAM ;GO MAKE A FRAME
HRRZ 3,CF
GETAL 3,3
PUSH PP,0(3)
SOJG 6,.-2
JRST 2(7)
BINDP1: POINT 9,0(7),8
;BINDER FOR BLOCKFN THAT MAKES A FRAME
;EFF ADDR OF UUO IS ADDR OF LITS - FIRST LIT IS FN NAME
;REST ARE ARG#,,ARGNAME
;BYTES 9 ARGTY FRAMSIZ #LITS FFSIZ
;IF FN IS LAMA THEN AC1 HAS # ARGS GIVEN.
BBINDQ: POP CP,7 ;EXTRA RETURN DUE TO UUO
MOVE 6,BINDP1
LDB 2,6 ;ARGTY
CAIN 2,2
JRST BB4
ILDB 1,6
BB5: MOVE 4,@40 ;FN NAME
JSP 5,CFRAM ;MAKE FRAME
MOVEI 2,@40
ILDB 3,6 ;GET # LITS (INCL. FN NAME)
MOVN 3,3
HRLI 2,0(3)
JRST BB1
BB2: MOVS 3,0(2) ;PUT NAMES IN FOR SPECVARS
TRNE 3,400000
MOVEI 3,ASZ(1) ;LAMA BINDS TO LAST ARG
ADDI 3,-ASZ(VP)
HLLM 3,0(3)
BB1: AOBJN 2,BB2
HRRZ 3,CF
MOVSI 1,400000
IORM 1,NARWD(3) ;HI BIT SET FOR BLOCK FRAME
ILDB 1,6 ;MOVE FF DOWN
JUMPE 1,BB3 ;NO FF
GETCL 2,3
GETPPI 2,2 ;FF OF CALLER
MOVEI FF,0(2)
MOVN 1,1
HRLI 2,0(1)
BB6: MOVE 4,1(2) ;IF WAS N(FF), TURN BACKTO ABSOLUT PTR
TLNN 4,20 ;LEAVE LOCALFREEVARS AS IS
MOVEI 4,@4
PUSH PP,4
AOBJN 2,BB6
BB3: GETPPI FF,3
JRST 1(7)
BB4: MOVEI 4,ASZ(1)
PUSH PP,4
IBP 6
AOJA 1,BB5
;BOX EFF ADR FROM COMPILED CODE
IBOXQ: HRRZ 1,@40
CAIGE 1,MSN/2
CAMG 1,[-MSN/2]
JRST MKN1
ADDI 1,ASZ
RET
;UNBOX EFF ADR FROM COMPILED CODE
IUBQ: HRRZ 1,@40
IUBQ1: LDT 2,1
CAIN 2,SMALLT
JRST IUBQS
CAIE 2,FIXT
JRST IUBQ2
MOVE 1,0(1)
RET
IUBQS: SUBI 1,ASZ
RET
IUBQ2: CAIE 2,FLOATT
JRST IUBQE
MOVE 1,0(1)
JRST FLTFX
IUBQE: ERROR1 12,.+1
HRRZ FF,CF
GETPPI FF,FF
JRST IUBQ1
;SETN FROM COMPIILED CODE, E OF UUO IS VAR LOC
;AC1 NUMBER, 2 TYPE
SETNQ: HRRZ 4,@40 ;OLD VALUE(PTR)
LDT 5,4
CAIE 5,FIXT
CAIN 5,FLOATT
JRST SETN1
PUSH CP,40 ;GC CAN CLOBBER
CALL GBOX ;BOX NEW
POP CP,40
HRRM 1,@40 ;STORE NEW VAL(PTR)
RET
SETN1: MOVEM 1,0(4) ;STORE NEW VAL IN OLD BOX
MOVEI 1,0(4) ;RET PTR
RET
;ERROR ROUTINES
;ERROR UUO
ERR0Q: MOVEI 1,0
ERRQ: MOVEM 1,ERRVAL ;MESSAGE VALUE
LDB 1,UUACP ;LOW ORDER 4 BITS OF ERROR NUMBER
MOVEM 1,ERRNM
LDB 1,[POINT 2,40,20] ;HIGH ORDER 2 BITS
LSH 1,4
IORM 1,ERRNM
HRRZ 1,40 ;CONTINUE LOCATION
TRZ 1,300000 ;FLUSH NUMBER BITS
MOVEM 1,0(CP) ;REPLACES UUO RETURN ON STACK
TRNE F,RMFLG ;READ BLIP?
PUSH PP,[READ,,0] ;YES - MAKE SURE READMACROS ARE OFF
LCALL KERRX,0 ;CALL ERRORX
HLRZ 2,(PP) ;READ BLIP?
CAIN 2,READ
SUB PP,BHC+1 ;YES - DELETE IT.
RET
;SIMPLE ERRORX IF NO EXPR LOADED
ERRX: HRRZ 1,CF
CALL FERSET ;LOOK FOR ERRORSET
JUMPE 1,ERRX1 ;NO ERRORSET
PUSH CP,1 ;SAVE ERRORSET POSITION
HRRZ 2,@KESGAG ;TEST ESGAG
CAMN 2,KT
JRST ERRX3 ;T => PRINT MESSAGE AND BACKTRACE
HRRZ 1,0(1)
HRRZ 1,2(1) ;ERRORSET (2ND ARG) FLAG
CAMN 1,KNIL
JRST ERRX4 ;NO MESSAGE
ERRX3: CALL ERRORN
CALL ERRORM ;PRINT MESSAGES
HRRZ 2,@KESGAG
CAMN 2,KT
CALL BACKTR ;T => DO BACKTRACE
ERRX4: POP CP,1
JRST ERRF1 ;RETURN NIL FROM ERRORSET
ERRX1: SKIPE ERRDSP
JRST ERRX5 ;ALREADY IN BACKTRACE
CALL ERRORN
CALL ERRORM
ERRX2: CALL BACKTR
ERRX5: SETZM ERRDSP
JRST RESET
U ERRDSP
;GET ERROR NUMBER AND MESSAGE OF LAST ERROR
ERRORN: MOVE 1,ERRVAL ;MESSAGE
MOVE 2,KNIL
JUMPE 1,ERRN1 ;NO MESSAGE
CALL CONS
MOVEI 2,0(1)
ERRN1: MOVE 1,ERRNM ;NUMBER
ADDI 1,ASZ ;BOX IT
JRST CONS
U ERRVAL
U ERRNM
;PRINT ERROR DIAGNOSTIC AND MESSAGE
ERRORM: PUSH PP,1
CARA 1,1 ;ERROR NUMBER
CALL IUNBOX
TMSG EOLM
TMSG @ERRMT(1) ;DIAGNOSTIC
TMSG EOLM
POP PP,1
CDRA 1,1
CAMN 1,KNIL ;MESSAGE?
RET ;NO
CARA 1,1
JRST PRINTX
; CONVERT ERROR NUMBER TO STRING
ESTRNG: CALL IUNBOX
HRRZ 1,ERRMT(1)
HRLI 1,440600
PUSH CP,1
CALL MKSTRS
ESTRN3: ILDB 1,0(CP)
CAIN 1,"/"-40 ;THE CHAR / TERMINATES ERROR MESSAGES
JRST ESTRN2
ADDI 1,40 ;CONVERT TO 7 BIT
CALL MKSTR1
JRST ESTRN3
ESTRN2: SUB CP,BHC+1
MOVE 1,UNP1
JRST MKSP
;SET ERROR NUMBER
SERRN: MOVEM 2,ERRVAL
CALL IUNBOX
MOVEM 1,ERRNM
JRST FALSE
;ERRORSET
ERRSET: CALL EVAL
MOVE 2,KNIL ;RETURN LIST OF VALUE
JRST CONS
;ERROR! DOES QUICK RETURN TO ERRORSET
ERRORE: JSYS INTFX ;FROM ↑E
ERRORF: HRRZ 1,CF
CALL FERSET ;FIND IT
JUMPE 1,SRESET ;NO ERRORSET SO RESET
ERRF1: HRRZ 2,KNIL
JRST RETU2
ERROR: ERROR1 21,R ;USER INITIATED ERROR
;FIND ERRORSET - 1 HAS IPOS TO BEGIN LOOKONG
FERSET: MOVEI 3,0(1)
HRRZ 1,KERSET
MOVNI 2,1 ;THE FIRST
JRST STKPOS
;BACKTRACE(FROM TO N)
;BITS IN N - 1 PRINT ARGS, 2 PRINT FORMS, 4 PRINT SUBR ARGS & JUNK
;10 DONT PRINT UNTRACE: OR FN NAME, 20 CHASE ALINKS
UBAKTR: CALL STKGP
JUMPE 1,STKER1
PUSH PP,1
HRRZ 1,2(VP)
CAMN 1,KNIL ;DEFAULT EPOS IS TOP
HRRZ 1,KT
CALL STKGP
JUMPE 1,STKER2
POP PP,7 ;BEG
MOVEI 6,0(1)
HRRZ 3,3(VP) ;FLG
JRST BT
BACKTR: HRRZ 1,KT
CALL STKGP ;GET TOP
MOVEI 6,0(1)
HRRZ 7,CF ;WHOLE STACK
MOVEI 3,ASZ+1 ;PRINT VARS, NO FORMS, NO SUBR ARGS
BT: SETOM ERRDSP ;SET FLAG FOR ERRORX
CAMN 3,KNIL
MOVEI 3,ASZ+1 ;STANDARD IS VARS, NO FORMS NO SUBR ARGS
MOVEI TF,-ASZ(3) ;SETUP TEMP FLAGS
TRNN TF,10
TYPEQ <$UNTRACE:$>
MOVE 2,KT
CALL OFSET
MOVE 2,BTPC
TRNE TF,20
MOVE 2,BTPA
MOVEM 2,STKPX
BT10: JUMPE 7,BTVR
TRNN TF,6 ;PRINTING EVAL BLIPS OR JUNK?
JRST BTV3 ;NO
TRZ F,NEGFLG
GETPPI 3,7
HRRZ 4,PP
CAMN 7,CF
JRST BTV2
GETCPO 4,7
HLRZ 4,0(4) ;PPO
BTV2: SUBI 4,0(3)
HRLI 3,4
JUMPE 4,BTV3 ;NO TEMS
BTV1: HLRZ 1,@3
CAIN 1,EVBLIP
JRST BTEV
TRNN TF,4 ;JUNK WANTED TOO?
JRST BTV3 ;NO
MOVE 5,[XWD -NBLIPS,BLIPTB]
BTV12: HLRZ 2,0(5)
CAIE 2,0(1)
JRST BTV13
HRRZ 1,0(5)
SKIPA 1,0(1)
BTV13: AOBJN 5,BTV12
BTV11: CALL BTNV ;PRINT 'NAME AND VALUE
SOJG 4,BTV1
BTV3: TRNN TF,1 ;PRINTING BINDINGS?
JRST BTN ;NO
HRRZ 3,0(7) ;BEG ARRGS -1
GETNAR 4,7
JUMPE 4,BTN ;NO ARGS
HRLI 3,4
TRZ F,NEGFLG
BTV31: HLRZ 1,@3
STE 1,ATOM
JRST BTV32 ;FUNNY ARG NAME
CALL BTNV ;PRINT NAME AND VALUE
BTV33: SOJG 4,BTV31
BTN: TRNE TF,10
JRST BT2 ;SUPPRESS NAME
HRRZ 3,0(7)
GETNAR 4,7
ADDI 3,0(4)
HRRZ 1,1(3)
STE 1,ATOM
JRST BTN1 ;FUNNY FN NAME
CALL BTPX
SKIPA
BTN1: TYPEQ <***$>
BT2: CAIN 7,0(6)
JRST BTVR
XCT STKPX
JRST BT10
BTV32: TRNN TF,4 ;PRINT SUBR ARGS??
JRST BTV33 ;NO
HRRZ 1,@3
CAMN 1,KNIL ;IS ARG NOT NIL,
TRNE F,NEGFLG ;OR ONE OR MORE ALREADY PRINTED?
JRST .+2 ;YES
JRST BTV33 ;NO, DONT PRINT THIS ARG
TRON F,NEGFLG
TCH EOL ;BLANK LINE BEFORE FIRST ARG
TYPEQ < > ;INDENT
TYPEQ <*ARG> ;USE ARG# FOR UN-NAMED ARGS
MOVEI 2,@3
SUB 2,0(7)
TCH "0"(2) ;ARG #
CALL BTPV ;PRINT SPACE AND VALUE
JRST BTV33
BTEV: HRRZ 1,KFORM
JRST BTV11
BTNV: TRON F,NEGFLG
TCH EOL
TYPEQ < >
CALL SAV27
MOVE 2,KT
MOVE 3,KT
CALL PRIN2
CALL RES27
BTPV: TCH " "
HRRZ 1,@3
BTPX: CALL SAV27 ;SAVE AC'S 2-7
CALL PRINTX
BT1Y: CALL RES27
RET
BTVR: SETZM ERRDSP
JRST TRUE ;RETURNS T IF NORMAL, NIL IF INTERRUPTED
BTPC: GETCL 7,7
BTPA: GETAL 7,7
BLIPTB: XWD EVBLIP,KFORM
XWD PRBLIP,KTAIL
XWD AVBLIP,KAVAL
XWD FNBLIP,KFN
XWD FNBLIP+1,KFN
XWD FNBLIP+2,KFN
XWD FNBLIP+3,KFN
NBLIPS==.-BLIPTB
;INTERRUPT ROUTINES
DEFINE EINT
< IFE TEN50,<
JSYS EINTR ;ENTER INTERRUPTED STATE
>>
DEFINE EINT1
< IFE TEN50,<
JSYS EINTR1
>>
DEFINE INTOFF
< AOS NOFLG
>
DEFINE INTON
< XCT INTONX
>
INTON1: XWD INTONR,.+1
SKIPG NOFLG ;INTERRUPT OK NOW?
JRST .+3
SOS NOFLG ;NOT YET
JRST @INTONR
MOVE 1,RSTONX ;RESTORE SWITCH
MOVEM 1,INTONX
RSTONX: SOS NOFLG
JRST @GINTD ;AND GO DO IT
;FIXUP BEFORE CALLING A FUNCTION AFTER AN INTERRUPT
INTFX: XWD INTFXX,.+1
SKIPG TP,CF
0 ;THIS SHOULDNT HAPPEN - CATCH
HRLI CP,@ICPC
HRLI PP,@IPPC
CAILE TP,-FLGWD(CP) ;PARTIAL FRAME?
JRST INTFX1 ;YES
INTFX2: TLNE CP,-1 ;CP FULL? -I.E. ABOUT TO POPJ?
JRST INTFX3
INTOFF
JSP 7,ECOPCO
JRST CPFUL
INTON
INTFX3: JRST @ INTFXX
INTFX1: CAIN TP,-CLWD(CP) ;AT CLINK WORD?
POP CP,3 ;YES - BACK UP TO CLINK OF CF
STE 3,STACK
0 ;CATCH CROCKS
HRRZM 3,CF
JRST INTFX2
U INTFXX
EINTR: XWD EINTRX,.+1
MOVEM CP,RSTCP ;SAVE MAIN STACK
MOVE CP,IIP ;SETUP LOCAL STACK
EINTRA: PUSH CP,RSTCP
PUSH CP,1
JRST @EINTRX
EINTR1: XWD EINTRX,.+1
MOVEM CP,RSTCP
MOVE CP,IIP1
JRST EINTRA
;RETURN FROM INTERRUPT
RSTC: POP CP,1
POP CP,CP ;RESTORE STACK, AC'S
DEBRK ;DISMISS INTERRUPT
TRAP: EINT1
TRAP1: PUSH CP,40
TYPEQ <$TRAP AT LOCATION >
HRRZ 1,LPC1
CALL PNO8
POP CP,40
MOVEI 1,DDTC
EXCH 1,LPC1
MOVEM 1,TRPLPC
JRST RSTC
U TRPLPC
;WRITE TRAP FIDDLER
WTRP: EINT1
PUSH CP,2
MOVEI 1,400000
GTRPW
PUSH CP,1 ;SAVE TRAP WORRD
PUSH CP,2 ;AND WRITE DATA
MOVEI 1,0(1)
CAMN 1,FTRAP ;IS IT FREE VAR TRAP?
JRST FTRP
LSH 1,-LPS ;PAGE CAUSING TRAP
CAMN 1,PPTRP
JRST WTRP1 ;MAGIC PP OVERFLOW PAGE
HRLI 1,400000
RPACS
TLNE 2,(1B6) ;INDIRECT PTR?
JRST WTRP3
MOVSI 2,130400 ;NO
SPACS ;CHANGE ACCESS
WTRP5: MOVSI 2,PVTBIT
IORM 2,TYPTAB(1)
WTRP2: POP CP,2
POP CP,1
TLNN 1,12 ;WRITE REQUIRED?
MOVEM 2,0(1) ;DO THE OFFFENDING WRITE
POP CP,2
JRST RSTC
WTRP1: MOVNI 2,1
AOBJN 2,.+1
JUMPE 2,FTRP ;KI-10 -ALL REFS TO MAGIC PAGE ARE FTRP
JRST FTRP3
WTRP3: PUSH CP,1 ;FORK,,PG 1,ACCESS 2
RMAP
TLNN 1,400000
JRST WTRP4 ;NOT A FORK
HRRM 1,0(CP) ;SAVE PAGE #
HLRZ 2,1
HLRZ 1,0(CP) ;GET FORK HANDLE USEABLE IN CURRENT
CALL TGFRKH
JRST WTRP4 ;PUNT
HRLM 1,0(CP)
MOVE 1,0(CP)
RPACS ;GET IMM AND INDIR ACCESS
TLNE 2,(1B6) ;INDIR?
JRST WTRP3+1 ;YES - GO TIL ISNT
WTRP4: POP CP,1
MOVSI 2,130400
SPACS
TLNN 1,377777
JRST WTRP5
CALL FRKHN ;TRANS FORM FORK HANDLE TO NUMBER
MOVEI 2,FPVTBT
CALL SFRKB ;SET PVT BIT
JRST WTRP2
;The following is a temporary GFRKH routine. There are several
;problems. GFRKH is not yet implemented at PARC and other places still
;running Tenex 1.31. It is in 1.32 and versions of 1.31 which are
;close to 1.32, e.g. those at BBN as of this writing, May '74.
;Secondly, thou shalt not do GFRKH's like this without corresponding
;RFRKH's. Otherwise, eventually something like CFORK will refuse
;to work merely for want of a name (400000 - 400030) for its output.
;Finally it is not clear that any case ever arises in which indirect
;page pointer chains go more than one level deep, or that if such cases
;do arise, one wants to chase clear to the bottom. However, that is
;the only approach that guarantees continuation. Even this code would
;lose if the page were ultimately found in a file opened for reading
;only.
;The fix here is to avoid calling GFRKH on the first iteration of the
;loop when it is a NOP anyway ("Give me a fork handle useable in fork
;400000 for the fork which is known as X to another fork I know about,
;namely, myself.). If it ever goes deeper than that, we call GFRKH
;and the hell with it.
TGFRKH: CAIE 1,400000
JRST TGFRK1
HRRZI 1,(2)
JRST .+3
TGFRK1: GFRKH
RET
AOS 0(CP)
RET
;FORK HANDLE,, PG IN 1
;GET FORK#,, PAGE IN 1, 0 IF BAD
FRKHN: PUSH CP,3
MOVE 2,[XWD -NFRKS,FRKHT]
MOVSS 1
FRKHN1: HLRZ 3,0(2)
CAIN 3,0(1)
JRST FRKHN2
AOBJN 2,FRKHN1
HLRZ 1,1
FRKHN3: POP CP,3
RET
FRKHN2: MOVSS 1
HRLI 1,-FRKHT(2)
JRST FRKHN3
U FRKHT,NFRKS
U EINTRX,1
U LPC1,1 ;INTERRUPT LEVEL PC'S
U LPC2,1
U LPC3,1
U NOFLG
U INTONX
U INTONR
;TENEX PSI LEVEL AND CHANNEL TABLES
LEVTAB: XWD 0,LPC1
XWD 0,LPC2
XWD 0,LPC3
CHNTAB: XWD 2,RSTU0 ;USER INTERRUPT
XWD 2,RST1P ;↑P
XWD 2,RST1F ;↑S
XWD 2,RST1R ;RUBOUT
XWD 2,RST1E ;↑E
XWD 2,RST1Z ;↑D
XWD 0,0 ;OVERFLOW
XWD 0,0 ;FLOATING OVERFLOW
XWD 0,0 ;UNUSED
XWD 1,PDLTRP ;PDL OVF
XWD 0,0 ;EOF
XWD 0,0 ;DATA ERR
XWD 0,0 ;FILE (UNASSIGNED)
XWD 0,0 ;FILE (UNASSIGNED)
XWD 0,0 ;TOD
XWD 1,TRAP ;INSTRUCTION
XWD 1,WTRP ;MEM READ
XWD 1,WTRP ;MEM WRITE
XWD 1,TRAP ;MEM XCT
XWD 0,0 ;FORK
XWD 0,0 ;MACHINE SIZE
XWD 2,RST1E ;↑C - NORMALLY NOT ACCTIVATED
XWD 0,0 ;UNUSED
XWD 0,0 ;UNUSED
XWD 2,RSTU1 ;USER INTERRUPT
XWD 2,RSTU2 ;DITTO
XWD 2,RSTU3 ;DITTO
XWD 2,RSTU4 ;DITTO
XWD 2,RST1O ;↑O - 28.
XWD 2,RST1H ;↑H
XWD 2,RST1B ;↑B
XWD 2,RSTU5 ;USER INTERRUPT
XWD 2,RSTU6 ;USER INTERRUPT
XWD 2,RSTU7 ;DITTO
XWD 2,RSTU8 ;DITTO
XWD 2,RSTU9 ;DITTO
;TABLE TO INIT TERM INTERRUPTS
DEFINE STC (T,C)
< XWD "T"-100,C>
OCTCT: STC H,35
STC P,1
STC S,2
XWD 34,3 ;RUBOUT
STC E,4
STC D,5
STC O,34
STC B,36+400000 ;HARD INTERRUPT
XWD 400000,0 ;USER INTERRUPTS
XWD 400000,30
XWD 400000,31
XWD 400000,32
XWD 400000,33
XWD 400000,37
XWD 400000,40
XWD 400000,41
XWD 400000,42
XWD 400000,43
U CTCT,↑D18
UCTCT=CTCT+8 ;BEGINNING OF USER PORTION OF TABLE
U UCTVAR,↑D10 ;THE INTERRUPT VARIABLES
UCTVRP: XWD -↑D10,UCTVAR
CTCTP: XWD -↑D18,CTCT
UCTCTP: XWD -↑D10,UCTCT ;FOR JUST LOOKING AT THE USER CHARS.
CTCTC: STC C,25
FTRP: CALL SAV27
SKIPA 2,CF
FTRP1: GETCL 2,2
GETPPI 3,2 ;THE RESET PP
MOVE 1,@LPC1 ;THE OFFENDING INSTR. N(FF)
ADD 1,1(3) ;ADDR. OF VARIABLE NAMES
LDT 3,1
CAIE 3,CCODET ;REGULAR CODE?
ADDI 1,0(BR) ;NO - RELOCATE
HRRZ 1,-2(1) ;DESIRED VARAIBLE NAME
HRRZ 2,CF
CALL PPLOK2 ;GET VAL
JFCL ;NOT ON STACK - OK
MOVE 2,@LPC1
TLZ 2,20 ;FLUSH IBIT
HRRZM 1,@2 ;NOTE THAT HERE IT IS NECESSARY
AOS TRPCNT ;THAT STACK AND TEMS BE WRITABLE
CALL RES27
JRST WTRP2
FTRP2: CALL RES27
FTRP3: SUB CP,BHC+2
POP CP,2
JRST TRAP1
PDLTRP: EINT1
CALL SAV27
HLRZ 1,IPD1 ;CHECK LEFT SAVED CP
JUMPE 1,PDLTRC ; IF = 0, CP BLEW
TLNE PP,-1 ;OR WAS IT PP
JRST PDLTR2 ;NEITHER JUST ERROR
PDLTPP: JSP 7,ECOPPO ;COPY IF POSSIBLE
JRST IPPFUL ;REALLY FULL - EMERGENCY TOO
JRST PDLTR3
PDLTRC: HRRZ 1,LPC1
CAILE 1,EFNCAL ;IN CRUCIAL 3 PUSH'S ?
CAILE 1,XFNCA
JRST .+3
ADDI 1,XFNCC-XFNCA ;YES - SWITCH TO RESUME SUCH THAT
HRRM 1,LPC1 ;.. RET FLG WILL BE PPRC
EXCH CP,IPD1 ;GET ORIG. CP BACK FOR A SEC
JSP 7,ECOPCO ;COPY STACK IF POSSIBLE
JRST ICPFUL
PDLTR4: EXCH CP,IPD1
PDLTR3: CALL RES27
JRST RSTC ;GO DEBRK
PDLTR2: MOVEI 1,PDLERR ;SOME OTHER STACK
PDLT22: MOVEM 1,LPC1
JRST PDLTR3
IPPFUL: TRNE F,GCFLG ;PPFULL IN INTERRUPT
JRST IPPF2
IPPF1: MOVEM CP,IPD1 ;SAVE INTERRUPT CP
JSP 7,RESTK ;NOT IN GC - FOR NOW FLUSH STACK
EXCH CP,IPD1 ;GET INTERUPT CP BACK,SET NEW RUN CP
MOVEI 1,PDLER1
JRST PDLT22
IPPF2: HALTF ;PP FULL DURING GC!! WHAT TO DO??
PPFUL: ;STACK REALLY FULL (EMERGENCT TOO)
CPFUL: JSP 7,RESTK ;FOR NOW JUST RESET STACKS
PDLER1: TYPEQ <$STACK OVERFLOW$>
JRST EVQ2
PDLBRK: SKIPG TP,CF ;GET HERE WHEN STACK FULL AND TERM INTS BACK ON
0 ;CATCH CROCKS - SHOULDNT HAPPEN
CAIG TP,-FLGWD(CP) ;PARTIAL FRAME?
JRST PDLBR1 ;NOPE
MOVEI TP,0(CP) ;YES - HAD TO BE IN PROCESS OF MAKING IT
SUB TP,CF
JRST .+1(TP) ;SO FINISH IT
PUSH CP,3
PUSH CP,3
PUSH CP,HCRETC
HRLM 1,-3(CP) ;SET # ARGS
PUSH PP,2 ;AND FN NAME
HRLM PP,-2(CP) ;AND PPI
PDLERR: ERROR0 2,RESET
PDLBR1: HRRZ TP,CF ;EXT IS COMPLETE - CHECK BASIC FR.
GETPPI 3,TP
JUMPN 3,PDLERR ;PPI IS SET SO OK
MOVEI 3,0(PP) ;PPI NOT SET
SUB 3,0(TP) ;ASSUME EVERYTHING ON PP IS ARGS
HRLM 3,NARWD(TP)
MOVEI 2,0(2)
PUSH PP,2 ;FN NAME - HOPEFULLY - BUT NEED CXT
SETPPI PP,TP
JRST PDLERR
U STKMOD ;CONTAINS STATE OF STACK
SMPR==1 ;PPSTACK IS IN EMERGENCY REGION
SMCR==2 ;CP STACK IS IN EMERGENCY REGION
SMCM==4 ;CP HAS BEEN MAPPED (DURING GC)
;CP OVERFLOW IN GC - MAP OUT STUFF FROM LCALQ TO CLRBUF
;APPROX 6000Q WDS. TO USE FOR STACK DURING GC
OVCP=LCALQ+777 ;APPROX. BEGINNING (MACRO EATS IT)
OVEND=CLRBUF ;APPROX.END OF TEMP STACK
ICPFUL: EXCH CP,IPD1
TRNN F,GCFLG
JRST IPPF1 ;NOPE
HRRZ 2,IPD1
CAIG 2,OVEND
CAILE 2,OVCP ;ALREADY USING TEMP STACK?
JRST .+2
HALTF ;YES -DIE
MOVEI 4,OVEND
LSH 4,-LPS ;LAST PG+1
MOVEI 5,OVCP ;COMPUTE FIRST WD OF STACK
ANDI 5,-NPS
SUBI 5,1 ;FIRST WD-1
MOVEI 1,OVCP
LSH 1,-LPS ;FIRST PG OF STACK
HRLI 1,400000
ICPF3: MOVEM 1,ICPT1
RMAP
EXCH 2,ICPT1 ;SAVE ACCESS
MOVEM 1,ICPT2 ;AND MAP
HRREI 1,-1 ;FLUSH PAGES
PMAP
PUSH 5,ICPT1 ;SAVE ACCESS
PUSH 5,ICPT2 ;AND MAP OF FLUSHED PAGE
AOS 1,2
CAIE 4,0(2)
JRST ICPF3
PUSH 5,CF
HRL 5,CF
AOBJN 5, ;COPY FROM C(CF)+1 TO C(5)+1
HRRZ 2,IPD1
ADDI 2,-1(5)
SUB 2,CF
BLT 5,0(2) ;COPY CP
MOVEI 3,OVEND ;COMPUT STACK LEN
ANDI 3,-NPS
SUBM 2,3
HRLI 2,1(3)
MOVEM 2,IPD1 ;RESET CP FOR DEBRK
JRST PDLTR3
OVFIX: POP CP,5
MOVEI 2,OVEND-NPS
LSH 2,-LPS
MOVEI 4,OVCP-NPS
LSH 4,-LPS
HRLI 2,400000
OVFIX1: POP CP,1
POP CP,3
PMAP
SOS 2
CAIE 4,0(2)
JRST OVFIX1
MOVE CP,5
JRST 0(7)
U ICPT1
U ICPT2
RST1P: EINT
CALL RSTRN ;GET NUMBER
PUSH CP,2
MOVE 2,RSTSUM
CAIN 1,"."
JRST RST2P ;SET FOR THIS PRINT
CAIE 1,"!"
JRST RST3P ;ABORT
MOVEM 2,PPLVL ;SET PERMANENT LEVEL
RST2P: MOVEM 2,TPLVL
RST3P: POP CP,2
JRST RSTC
RSTRN: SETZM RSTSUM
PUSH CP,2
PUSH CP,3
PUSH CP,4
PUSH CP,FX
MOVEI FX,0
IFN TEN50,< CALL CLRBUF>
IFE TEN50,< PUSH CP,SYSBFP
PUSH CP,[0]
MOVEI 1,RSTRS
CALL CLRBSS ;SAVE CURRENT TTY IN BUFFER
CLRTOB
>
MOVEI 1,"π" ;TYPE BELL
CALL TCO
MOVE 1,FILEN(FX)
IFE TEN50,< DOBE ;WAIT TILL REALLY OUTPU
>
RST1P1: CALL TCI
CAIG 1,"9"
CAIGE 1,"0"
JRST RST1P2
SUBI 1,"0"
EXCH 1,RSTSUM
IMULI 1,↑D10
ADDM 1,RSTSUM
JRST RST1P1
RST1P2:
IFE TEN50,< POP CP,4
MOVE 3,SYSBFP
MOVEM 1,0(CP)
CALL BKSYS2 ;RESTORE INPUT BUFFER
POP CP,1
>
POP CP,FX
POP CP,4
POP CP,3
POP CP,2
RET
RSTRS: IDPB 1,-3(CP)
AOS -2(CP)
RET
U RSTSUM
U IPD,NIP
IIP: IOWD NIP,IPD
U IPD1,NIP
IIP1: IOWD NIP,IPD1
;CONTROL-F - SET MINLW
RST1F: EINT
CALL RSTRN
CAIE 1,"."
JRST RSTC
MOVEI 1,MINLW
TRNN F,GCFLG ;DOING GC?
JRST RST1F1 ;NO - SET MINFS LIST
MOVE 1,GCTYP ;YES - DO FOR TYPE COLLECTING
HRRZ 1,TYPBLK(1)
ADDI 1,TMIN
RST1F1: EXCH 1,RSTSUM
MOVEM 1,@RSTSUM
MOVEM 1,XMINARR ;IF ARRAYS MAKE MINFS PERMANENT
JRST RSTC
;RUBOUT - CLEAR TTY INPUT BUFFER
RST1R: EINT
CLRTIB
RSTTCG: MOVEI 1,"π"
JRST RSTTCO
;CONTROL - O CLEAR TTY OUTPUT BUFFER
RST1O: EINT
CLRTOB
MOVEI 1,EOL
RSTTCO: CALL TCO
JRST RSTC
;CONTROL - E CALL ERROR!
RST1E: EINT
CLRTOB
MOVEI 1,EOL
CALL TCO
CALL SCLRBF
MOVEI 1,ERRORE
JRST RSTE1
;CONTROL-H - INTERRUPT AT FN CALL
RST1H: EINT
MOVEI 1,1 ;INTERRUPT ARG
URST1: MOVEM 1,UINTCH
MOVE 1,RSTBK
MOVEM 1,FNCALL ;SET TO INTERRUPT AT NEXT FN CALL
TRO F,INTFLG
CLRTOB
CALL SCLRBF ;CLEAR BUFFER AND SAVE
JRST RSTTCG
;CONTROL-B - INITIATE ERROR
RST1B: EINT
TRO F,ERQFLG ;REGULAR ERROR, SET FLAG
MOVEI 1,BREAKB ; DO IMMEDIATELY
RSTE1: SKIPGE NOFLG ;INTERRUPTS FORBIDDEN?
TRNE F,GCFLG ;DOING GC NOW?
JRST RSTE3 ;YES, REMEMBER REQUEST
MOVEM 1,LPC2
PUSH CP,2
SKIPE INCTLA ;WERE WE IN ↑A MODE?
CALL FIXCTA ;YES.
RSTCU: POP CP,2
JRST RSTC ;AND GO DEBREAK
RSTE3: MOVEM 1,GINTD ;SAVE ADDRESS FOR
MOVE 1,INTDO ;SET TO DO IT WHEN PERMITTED
MOVEM 1,INTONX
JRST RSTC
INTDO: JSYS INTON1
BREAKB: JSYS INTFX
JRST XBREAK
;CONTROL-D
RST1Z: EINT
CLRTOB
MOVEI 1,EOL
CALL TCO
CALL SCLRBF
RRSET: MOVEI 1,RESETD
JRST RSTE1
SRESET:
IFE TEN50,< CALL CLRBFS ;CLEAR INPUT BUFFER AND SAVE IT
>
JRST RESET
RSTBK: CALL HBREAK ;CALL TO INITIATE INTERRUPT
RSTFC: XCT 1(2) ;NORMAL FUNCTION CALL INSTRUCTION
U GINTD
;SAFE CLEAR BUFFER
SCLRBF: PUSH CP,2
PUSH CP,FX
IFE TEN50,< CALL CLRBFS>
IFN TEN50,< CALL CLRBUF>
POP CP,FX
POP CP,2
RET
; INTERRUPT HANDLERS FOR USER INTERRUPT CHARS
DEFINE DUIC(X) <IRPC X,<
RSTU'X: EINT
MOVEI 1,X
JRST RSTUN>
>
DUIC (<0123456789>)
RSTUN: PUSH CP,2
MOVE 2,UCTCT(1) ;GET CHAR ENTRY
TLNE 2,400000 ;IS CHAR REALLY ON?
JRST RSTCU ;NO - STRAY INTERRUPT - IGNORE IT
TRNE 2,400000 ;YES - IS IT A HARD OR SOFT INTERRUPT?
JRST UHARD ;HARD
SKIPE 1,UCTVAR(1) ;IS THERE AN ASSOCIATED VARIABLE?
JRST UVARD ;YES, SET IT.
HLRZ 1,2 ;SOFT - CONVERT TO LETTER
ADDI 1,100
POP CP,2
JRST URST1 ;SIMILAR TO ↑H
UHARD: HLRZ 1,2 ;HARD - CONVERT TO NUMBER
ADDI 1,ASZ ;NEED TO BOX, NOT NEEDED FOR SOFT BREAKS
MOVEM 1,UHINCH
MOVEI 1,UBREAK
POP CP,2
JRST RSTE1
UVARD: PUSH CP,3 ;SAVE ACS
PUSH CP,4
PUSH CP,5
HRRZ 2,KT ;SET THE VARIABLE TO T.
CALL SET
POP CP,5 ;RESET THE ACS
POP CP,4
POP CP,3
JRST RSTCU
U UINTCH
U UHINCH
;PERFORM CONTROL ACTION AT TIME OF FUNCTION CALL
HBREAK: LDT 3,2 ;HERE ASSUME LDT AINT A UUO
CAIN 3,LISTT
JRST .+3
CAIE 3,ATOMT
JRST @1(2) ;IGNORE LINKED CALLS ETC.
PUSH PP,2 ;FINISH HALF COMPLETED FRAME
HRRZ 3,CF
SETPPI PP,3
SETNAR 1,3
XBREAK: MOVEM 1,FNCALL ;RESET FNCALL TO NORMAL
MOVE 1,RSTFC
EXCH 1,FNCALL
BREAKE: TRZE F,ERQFLG ;TEST VARIOUS REQUEST FLAGS
BREAK: ERROR0 22,R
TRZE F,INTFLG
JRST INTR1
TLZE F,CNSFLG
JRST CNSCI
SOS 0(CP)
POPJ CP, ;GO RE-EXECUTE CALLING INSTRUCTION
U RSTCP
UBREAK: MOVE 1,RSTFC ;HARD USER INTERRUPT
MOVEM 1,FNCALL
MOVE 1,UHINCH
ERROR1 53,R
CNSCI: PUSH CP,[3] ;INTERRUPT TYPE NUMBER
JRST INTRC
INTR1: PUSH CP,UINTCH
INTRC: PUSH PP,2 ;NAME OF FUNCTION ABOUT TO BE CALLED
MOVEI 6,-2
HRLI 6,PP
CALL LSTAR2 ;MAKE LIST OF ARGS ON STACK
PUSH PP,1 ;SECOND IS ARG LIST
POP CP,1
CALL MKN
PUSH PP,1 ;THIRD IS INT TYPE
LCALL KINT,3
RET
;CLEAR TTY I/O
CLRTIO: CLRTOB ;CLEAR OUTPUT BUFFER
JRST CLRBUF ;CLEAR INPUT BUFFER AND RESET EDIT LINE
;ERROR MESSAGES TABLE
;REMOTE MACRO
DEFINE REMOTE (TX)
< HERE1 <TX>>
DEFINE HERE1 (NEW,OLD,%G)
< DEFINE %G
< NEW>
DEFINE REMOTE (TX)
< HERE1 <TX>,<OLD
%G
>>>
DEFINE HERE
< DEFINE HERE1 (XX,YY)
< YY>
REMOTE>
;ERROR MESSAGES
DEFINE EM (MSG,%T)
< Z %T
REMOTE <%T: SIXBIT @MSG/@
>>
ERRMT: EM <NONXMEM>
EM <UNDEFINED FUNCTION>
EM <STACK OVERFLOW>
EM <ILLEGAL RETURN>
EM <ARG NOT LIST> ;4
EM <UNUSED>
EM <ATTEMPT TO SET NIL>
EM <ATTEMPT TO RPLAC NIL>
EM <UNDEFINED OR ILLEGAL GO> ;10
EM <FILE WON'T OPEN>
EM <NON-NUMERIC ARG>
EM <ATOM TOO LONG>
EM <ATOM HASH TABLE FULL> ;14
EM <FILE NOT OPEN>
EM <ARG NOT LITATOM>
EM <TOO MANY FILES OPEN>
EM <END OF FILE> ;20
EM <ERROR>
EM <BREAK>
EM <ILLEGAL STACK ARG>
EM <FAULT IN EVAL> ;24
EM <ARRAYS FULL>
EM <DIRECTORY FULL>
EM <FILE NOT FOUND>
EM <FILE INCOMPATIBLE - SYSIN> ;30
EM <UNUSUAL CDR ARG LIST>
EM <HASH TABLE FULL>
EM <ILLEGAL ARG>
EM <ARG NOT ARRAY> ;34
EM <ILLEGAL OR IMPOSSIBLE BLOCK>
EM <STACK PTR HAS BEEN RELEASED>
EM <LISTS FULL>
EM <ATTEMPT TO CHANGE ITEM OF INCORRECT TYPE> ;40
EM <ILLEGAL DATA TYPE NUMBER>
EM <DATA TYPES FULL>
EM <UNUSED>
EM <TOO MANY USER INTERRUPT CHARACTERS> ;44
EM <READ-MACRO CONTEXT ERROR>
EM <ILLEGAL READTABLE>
EM <ILLEGAL TERMINAL TABLE>
EM <SWAPBLOCK TOO BIG FOR BUFFER> ;50
EM <UNUSED>
EM <UNUSED>
EM <USER BREAK>
HERE
RESETE: SETOM NOFLG
MOVE 1,RSTONX
MOVEM 1,INTONX
JSP 7,RESTK ;FROM INIT,START,REE, AND FN RESET
MOVE F,TFLGS
SETOM SYSCHK
SETICH
CALL SETTRP
CALL RESET1
EVQ2: SETZM ERRDSP
SETZB BR,LSTSWF
SKIPE 2,STKMOD
JRST EVQ3
EVQ6: LCALL KEVLQT ;EVALQUOTE LOOP
JRST EVQ2
EVQ3: TRNN 2,SMPR ;STACK WAS IN EMERGENCY REGION
JRST EVQ4 ;... SEE IF ITS OUT NOW
HLRZ 3,PP
CAIG 3,-NREDPP ;IF SPACE EXCEEDS EMER.
TRZ 2,SMPR ;THEN OK NOW
EVQ4: TRNN 2,SMCR ;DITTO CP
JRST EVQ5
HLRZ 3,CP
CAIG 3,-NREDCP
TRZ 2,SMCR
EVQ5: MOVEM 2,STKMOD
JRST EVQ6
RESET1: TRZ F,-1 ;CEAR TEM FLGS
TLZ F,CNSFLG
SETZM GINTD
CIS
CALL SETMOD
MOVE 1,RSTFC
MOVEM 1,FNCALL
TMSG EOLM
RET
RESTK: INTOFF
SETZM STKMOD
MOVE CP,ICP ;RESET STACKS
MOVE PP,IPP
MOVEI VP,0(PP)
PUSH CP,VP ;SET UP AN INITIAL FRAME TO RUN IN
HRRZM CP,CF
PUSH CP,[0]
PUSH CP,[0]
PUSH CP,[XWD 0,RESET]
PUSH PP,KNIL
HRLM PP,-2(CP) ;SET PPI
PUSH CP,7
JSP 7,SETSPC ;SET IPPC,ICPC
CALL STKPPG ;NULLIFY ALL STACK POINTERS
CALL FLSTKP
INTON
RET
RESETD: JSYS INTFX ;FROM ↑D
RESET: CALL RESET1 ;FROM ERRORS
HRRZ 1,KT
CALL STKGP ;FIND TOP FRAME
INTOFF
JSP 7,UNSTK
MOVEI 3,0(1)
JRST PPRC31
EVALQT: MOVEI 1,"←" ;READY CHARACTER
CALL TCO
EVQ1: LCALL KREADX,0 ;READ FUNCTION
CAMN 1,KNIL ;IGNORE NIL (UNMATCHED RT. PAREN)
JRST EVQ1
PUSH PP,1
LCALL KREADX,0 ;READ ARG LIST
PUSH PP,1
LCALL KAPPLY,2 ;EVALUATE
PUSH PP,1
LCALL KPRINT,1 ;PRINT VALUE
RET
;CLEAR ALL STACK POINTERS - IF ARG T JUST RETURN LIST OF ACTIVE ONES
CLRSTK: CAME 1,KNIL
JRST CLSTK1
CALL STKPPG
CALL CLSTKA
JRST FALSE
CLSTKA: PUSH CP,7
CLSTKB: MOVEI 1,0(3)
HRRZ 2,0(1)
STN 2,STACK
CALL RELSTK
AOBJN 3,CLSTKB
POP CP,7
RET
CLSTK1: PUSH PP,KNIL
CALL STKPPG
CALL CLSTK2
POP PP,1
RET
CLSTK2: SKIPE 2,0(3) ;RELEASED?
STE 2,STACK ;OR NOT TO STACK (E.G. FREE LIST)
JRST CLSTK3
MOVEI 1,0(3)
HRRZ 2,0(PP)
PUSH PP,3
CALL CONS
POP PP,3
HRRM 1,0(PP)
CLSTK3: AOBJN 3,CLSTK2
RET
U TFLGS
;MACROS FOR ACCESSING FUNCTION CALL FRAME
;FRAME FORMAT IS
; #ARGS,,PP OF BEG ARGS-1
; PPIN,,ALINK (PPIN IS BEG TEMS -1)
; USE,,CLINK
; CPOUT,,PPR
; ..
; ..
; PPOUT,,REAL RETURN (PPOUT EXCLUDES ARGS OF CALLED FN)
; BASIC FRAME ON PP CONTAINS ARGS FOLLOWED BY CXT,,FN NAME
;PPOUT AND CPOUT ARE ONLY VALID WHEN FRAME IS NOT ACTIVE
CPOWD==3
FLGWD==3
CLWD==2
USEWD==2
PPIWD==1
NARWD==0
NARSIZ==11 ;BYTE SIZE FOR # ARGS - USE SO CAN FIND ALL REFS
NARM1==777000 ;MASK FOR NON-ARG PART OF HALF-WORD
DEFINE GETNAR (A,B)
< LDB A,[POINT NARSIZ,0(B),17]>
DEFINE GETBAS (A,B)
< HRRZ A,0(B)>
DEFINE GETCPO (A,B)
< HLRZ A,3(B)>
DEFINE GETAL (A,B)
< HRRZ A,1(B)>
DEFINE GETPPI (A,B)
< HLRZ A,1(B)>
DEFINE GETCL (A,B)
< HRRZ A,2(B)>
DEFINE GETUSE (A,B)
< HLRZ A,2(B)>
DEFINE GETFLG (A,B)
< HRRZ A,3(B)>
DEFINE GETPPO (A,B)
< GETCPO A,B
HLRZ A,0(A)>
DEFINE SETNAR (A,B)
< HRLM A,0(B)>
DEFINE SETBAS (A,B)
< HRRM A,0(B)>
DEFINE SETCPO (A,B)
< HRLM A,3(B)>
DEFINE SETAL (A,B)
< HRRM A,1(B)>
DEFINE SETPPI (A,B)
< HRLM A,1(B)>
DEFINE SETCL (A,B)
< HRRM A,2(B)>
DEFINE SETUSE (A,B)
< HRLM A,2(B)>
DEFINE SETFLG (A,B)
< HRRM A,3(B)>
;FUNCTION CALL UUO FOR CALLS FROM COMPILED CODE
;AND FUNCTION CALLER FOR INTERPRETER
FNACAL: PUSH PP,1 ;"PUSH AC1 FIRST" ENTRY
FNCALQ: LDB 1,UUACP
HRRZ 2,@40 ;FN NAME
EFNCAL: MOVEI VP,0(PP) ;ENTRY WITH # ARGS IN 1,NAME IN 2
SUBI VP,0(1) ;SET RESET PP TO UNCOVER ARGS
HRLM VP,0(CP) ;SAVE RESET PP IN CALLERS FRAME
MOVEI 3,1(CP) ;NEW CF MUST BE SET BEF. NEXT PUSH
EXCH 3,CF ;IN CASE OVERFLOW
SETCPO CP,3 ;RESET CP TO CALLERS FRAME
PUSH CP,VP ;PTR TO FIRST ARG-1
PUSH CP,3 ;SET ALINK
PUSH CP,3 ;= CLINK
XFNCA: XCT FNCALL ;GO TO FN ENTRY
PPR: ;SIMPLE RETURN
POP CP,3 ;CLINK(=ALINK)
SUB CP,BHC+2 ;FLUSH REST OF FRAME
GETUSE 4,3 ;USE(CALLER)
HLRZ PP,0(CP) ;GETPPO(CALLER) TO RESET PP
HRLI PP,@IPPC ;FIX LEFT
SOJGE 4,PPRA ;USE(CALLER)>0?
PPRC4: HRRZM 3,CF ;RESET CURRENT FRAME
HRRZ VP,0(3) ;SET UP ARG PTR
R: POPJ CP, ;AND REALLY RETURN
PPRA: SETUSE 4,3 ;DECREM. USE(CALLER)
JSP 7,ECOP ;COPY CALLERS EXT.
JRST PPRC4
HCRET: XWD 0,PPR
U CF ;CONTAINS CURRENT FRAME ALWAYS
U OPP ;SAVED PP WHEN CURRENT FRAME INVALID
;MAKE A FRAME FOR COMPILED PROG AND LAMBDA AND RETFN IN BLOCK
;CALLED JSP 5,CFRAM WITH #ARGS IN 1, FN NAME IN 4, CALLERS ADDR IN 7
;PRESERVE AC'S 6 AND 7
CFRAM: MOVEI 2,CFRAM1 ;DUMMY ATOM
CFRAM1: JRST EFNCAL ;RET IS ALREADY STACKED
PUSHJ CP,.+1 ;XCT'D
HRLM 1,-3(CP)
PUSH PP,4 ;FN NAME
HRLM PP,-2(CP) ;SET PPI
HRRZ VP,-3(CP)
MOVEI 7,(7)
CAML 7,CBADDR ;SWAPPED?
CAMLE 7,CBADDR+1
JRST 0(5) ;NO
MOVE 3,BR
JSYS SWPFIX
PUSH CP,BR ;=0
MOVE BR,3
PUSH CP,[SWPRET]
MOVE 3,CF
MOVEM 3,LSTSWF
JRST 0(5)
;ENTRY SEQUENCE FOR HAND CODED FUNCTIONS
;#ARGS GIVEN 1N 1,NAME IN 2,
HCAL1Q: ;SPREAD EVAL,AND NO-EVAL ARE SAME
HCAL0Q: LDB 3,UUACP ;GET # ARGS NEEDED
HCSET2: SUBI 1,0(3) ;DIFFERENCE BET. # GIVEN AND NEEDED
JUMPLE 1,HCSET1(1) ;OK OR TOO FEW
SUB PP,BHC(1) ;TOO MANY FLUSH EXTRA
HCSET4: HRLM 3,-3(CP) ;NUMBER ARGS STACKED
PUSH PP,2 ;STORE NAME FOLLOWING ARGS
HRLM PP,-2(CP) ;SAVE PPIN
HRRZ VP,-3(CP) ;SET VP AGAIN INCASE PP MOVED
HRRZ 1,1(VP) ;ARGS TO 1-3
HRRZ 2,2(VP)
HRRZ 3,3(VP)
JRST @40
PUSH PP,KNIL ;FOR NOW MAX ARGS = 6
PUSH PP,KNIL
PUSH PP,KNIL
PUSH PP,KNIL
PUSH PP,KNIL
PUSH PP,KNIL
HCSET1: JRST HCSET4
;EVAL - NO-SPREAD
HCAL2Q: HRLM 1,-3(CP)
HCSET3: PUSH PP,2 ;STORE NAME
HRLM PP,-2(CP) ;SAVE PPIN
HRRZ VP,-3(CP)
JRST @40
;NO-EVAL, NO-SPREAD
HCAL3Q: HRLM 1,-3(CP) ;STORE # ARGS (1)
HRRZ 1,1(VP) ;GET ARG TO 1
JRST HCSET3
;HARDER RETURN, ALINK NOT EQ CLINK, OR CXT>0
;OR NOT RETURNING TO FRAME ABOVE, OR TEMS AND ARGS
;NOT CONTIGUOUS
PUSH CP,3 ;IMAGE OF EFNCAL - C-STACK OVF
PUSH CP,3 ;...RESUMES HERE
XFNCC: XCT FNCALL
PPRC: INTOFF
POP CP,3 ;GET CLINK
POP CP,6 ;AND ALINK
POP CP,2 ;AND PTR TO ARGS-1 - NOW EXT. IS GONE
HLRZ PP,6 ;GET PPI FROM ALINK WD,FLUSH TEMS(RETURNER)
LDB 4,PPRCP ;GET # ARGS FROM BAS WORD
ADDI 4,1(2) ;END BASIC FRAME(RETURNER)
HLRZ 5,0(4) ;GET CXT(RETURNER)
SOJGE 5,PPRC1 ;DECREMENT
LDB 5,PPRFP
ADDI 4,0(5) ;REAL END BASIC FRAME
CAIE 4,0(PP) ;IS BASIC FR. CONTIGUOUS WITH TEMS?
JRST PPRC2 ;NOPE
MOVEI PP,0(2) ;ARGS ARE IN ACTIVE PP
PPRC3: HRLI PP,@IPPC ;FIX LEFT PP
CAIN 3,0(6) ;ALINK=CLINK?
JRST PPRC31 ;YES
MOVEM CP,CF ;IN CASE FLFR CAUSES C-STACK OVF
MOVEI 2,0(6)
CALL FLFR ;FLUSH ALINK FRAME
JRST PPRC31
PPRCR: INTOFF ;ENTER HERE TO JUST RUN A FRAME
PPRC31: GETUSE 4,3 ;USE(CALLER)
SOJGE 4,PPRCB ;>0 ?
GETCPO 4,3 ;IS 0 , CAN RUN
CAIE 4,0(CP) ;IS CP CONTIGUOUS
JSYS RECP ;NO FIDDLE CP
PPRC7: HLRZ 4,0(CP) ;GET RESET PP
CAIN 4,0(PP) ;IS THAT CONTIGUOUS
JRST PPRC41 ;OK - GO TO STANDARD STUFF
JSYS REPP ;PP NOT CONTIG.-FIXIT...ENTRY FROM RESET
TLNE PP,-1 ;ANY SPACE?
JRST PPRC41 ;OK - GO RUN
PPRPPO: HRRZM 3,CF ;NO ROOM TO RUN IN PP
JSP 7,ECOPPO
JRST PPFUL ;REALLY FULL
JRST PPRC41
PPRC2: SUBI 4,0(2) ;FLUSH BASIC FRAME OF RETURNER
HRLI 4,STKHOL ;MARK BASIC FRAME AS HOLE
MOVEM 4,1(2)
JRST PPRC3
PPRCB: SETUSE 4,3 ;NEW USE(CALLER)
PPRCD: JSP 7,ECOP ;COPY FRAME EXT.
PPRC41: HRRZM 3,CF ;SAME AS PPRC4 ..BUT
INTON
HRRZ VP,0(3)
HRRZ 3,0(CP) ;...FAKE POPJ TO AVOID PDLTRP
SUB CP,BHC+1 ;IF GOING GROM 0 TO -1 LEFT CP
JRST 0(3)
PPRC1: HRLM 5,0(4) ;CXT(RETURNER)>0 DECREM.
HRLI PP,@IPPC
JRST PPRCD ;GO COPY CALLER W/O DECREM. USE
PPRCP: POINT NARSIZ,2,17
NFRESZ==8
PPRFP: POINT NFRESZ,2,8
;SET UP NEW CP AND ICPC, ABANDONS CURRENT STACK
;NEW CP IN 4, PRESERVES AC'S 1,2,3
;TERMINAL INTERRUPTS SHOULD BE OFF
RECP: XWD RECPX,.+1
HLRE 5,CP
JUMPE 5,PPRC5
MOVN 5,5 ;ABANDON CURRENT STACK
HRLI 5,STKHOL
MOVEM 5,1(CP) ;MARK A HOLE
PPRC5: MOVEI CP,0(4)
SETZ 5,
JSYS MRGHOL ;LLOK FOR HOL AFTER NEW CP
ADDI 5,0(CP)
MOVN 5,5
HRLI 5,CP
MOVEM 5,ICPC
HRLI CP,@5 ;ADJUST LEFT
JRST @RECPX
REPP: XWD RECPX,.+1
HLRE 5,PP ;PP NOT CONTIQUOUS
JUMPE 5,PPRC8
MOVN 5,5 ;MARK CURRENT STACK AS HOLE
HRLI 5,STKHOL
MOVEM 5,1(PP)
PPRC8: MOVEI PP,0(4) ;SET PP TO PPO OF NEW FR.,0 LEN.
SETZ 5,
JSYS MRGHOL ;DOES HOLE FOLLOW
ADDI 5,0(PP)
MOVN 5,5
HRLI 5,PP
MOVEM 5,IPPC
HRLI PP,@5 ;ADJUST LEFT
JRST @RECPX
U RECPX
;COPY CP PART OF FRAME EXTENSION
;CALL WITH BEGINNING IN 3, END IN 2, # SLOTS REMAINING ON CP IN 5
;AND CP TRUE
;RETURN WITH OLD BEGINNING STILL IN 3, PRESERVE AC1 AC7,
;OLD LENGTH IN PPT, NEW BEGINNING IN 4
;CP AND ICPC UPDATED, OLD CP HOLE MARKED. SKIP IF OK
;TERMINAL INTERRUPTS S/B OFF
CPCOP: XWD CCOPX,.+1 ;LOOK FOR A PLACE TO PUT IT
MOVEI 4,0(CP) ;LOOK AFTER CURRENT CP FIRST
JSYS MRGHOL
SUBI 2,-1(3) ;# NEEDED
MOVEM 2,PPT ;SAVE LENGTH NEEDED
CAIG 5,0(2) ;HOLE BIG ENUF?
JRST CPCOP1 ;NOPE
CPCOP4: MOVEI 6,1(4) ;USE HOLE, 4 IS BEG-1
HRLI 4,2
HRLI 6,0(3)
SKIPE 2
BLT 6,@4
MOVEI CP,@4 ;RESET CP TO NEW END
SUB 2,5 ;- UNUSED LEN HOLE
HRLM 2,CP
SUBI 2,0(CP)
HRLI 2,CP
MOVEM 2,ICPC
JRST CPCOPO
AOS CCOPX
JRST @CCOPX
CPCOP1: HRRZ 4,ICP
CPCOP3: CAIN 3,1(4) ;SKIP THE ONE WE ARE TRYING TO COPY
ADD 4,PPT ;... CPO MAY BE WRONG
HLRZ 5,1(4)
CAIN 5,STKHOL ;HOLE FOLLOWS?
JRST CPCOP2
CAIN 5,STKEND ;OR END OF BLOCK?
JRST CPCOP7
HLRZ 4,CPOWD+1(4) ;NO - CPO IS NEXT END
JRST CPCOP3
CPCOP2: HRRZ 5,1(4) ;HOL LENGTH
JSYS MRGHOL
CAILE 5,0(2) ;BIG ENUF?
JRST CPCOP4 ;YES - USE IT
ADDI 4,0(5) ;NO - TRY AGAIN
JRST CPCOP3
CPCOP7: HRRZ 4,1(4) ;NEXT STACK REGION
JUMPE 4,@CCOPX ;NO MORE STACK AT ALL
CAME 4,IREDCP ;LAST STACK REGION?
JRST CPCOP3 ;NO - JUST GO ON
MOVE 5,STKMOD ;YES
TROE 5,SMCR ;ALREADY IN EMER. MODE?
JRST CPCOP3 ;YEP - JUST GO ON
MOVEM 5,STKMOD ;NOPE - SET RED
JSP 6,PPCOPB ;AND SET TO BREAK WHEN INTS GO ON
JRST CPCOP3
;COPY PP PART OF AN EXTENSION
;SPECS DITTO TO CPCOP
PPCOP: XWD CCOPX,.+1
MOVEI 4,0(PP)
JSYS MRGHOL
SUBI 2,-1(3)
MOVEM 2,PPT ;SAVE LENGTH NEEDED
CAIG 5,0(2)
JRST PPCOP1
PPCOP4: HRRZ 2,PPT ;LENGTH
MOVEI 6,1(4)
HRLI 4,2
HRLI 6,0(3)
SKIPE 2 ;MAY BE NOTHING TO COPY
BLT 6,@4
MOVEI PP,@4
SUB 2,5
HRLM 2,PP
SUBI 2,0(PP)
HRLI 2,PP
MOVEM 2,IPPC
CPCOPO: MOVEI 4,1(4) ;NEW BEGIN
AOS CCOPX ;SKIP IF OK
JRST @ CCOPX
PPCOP1: HRRZ 4,IPP
PPCOP3: CAIN 3,1(4) ;SKIP THE ONE WE ARE TRYING TO COPY
ADD 4,PPT
HLRZ 5,1(4)
CAIN 5,STKHOL ;HOLE?
JRST PPCOP2
CAIN 5,STKEND ;OR END?
JRST PPCOP7 ;YES
AOJA 4,PPCOP3
PPCOP2: HRRZ 5,1(4) ;HOLE LENGTH
JSYS MRGHOL
CAMLE 5,PPT
JRST PPCOP4 ;THIS HOLE WILL DO
ADDI 4,0(5)
JRST PPCOP3
PPCOP7: HRRZ 4,1(4) ;NEXT STACK REGION
JUMPE 4,@CCOPX ;NO MORE STACK AT ALL
CAME 4,IREDPP ;LAST STACK REGION?
JRST PPCOP3 ;NO - JUST GO ON
MOVE 5,STKMOD
TROE 5,SMPR ;STK ALREADY IN EMERG. REGION?
JRST PPCOP3 ;YES - JUST GO ON AND LET IT DIE
MOVEM 5,STKMOD ;SET MODE TO RED
JSP 6,PPCOPB
JRST PPCOP3
PPCOPB: MOVEI 5,PDLBRK
SKIPGE NOFLG ;TERM INTS OFF BY SOFTWARE?
JRST PPCOP8 ;NO - MUST BE PROCESSING A TRAP
MOVEM 5,GINTD
MOVE 5,INTDO
MOVEM 5,INTONX ;SET TO BREAK WHEN INTS GO ON
JRST 0(6)
PPCOP8: MOVEM 5,LPC1 ;DEBRK TO A PDLERR
JRST 0(6)
U PPT
U CCOPX
;MERGE STACK HOLES
;5 HAS # OF EMPTIES SO FAR(FROM CURRENT CP OR FIRST HOL FOUND)
;4 HAS CURRENT POS -1
;RETURN W / MERGED LENGTH IN 5
;AND UPDATED MARKER IN FIRST HOLE
;PRESERVE ALL OTHER AC'S BUT 6
MRGHOL: XWD MRGHX,.+1
HRLI 4,5
MRGH2: MOVEI 6,@4
CAIE 6,0(PP)
CAIN 6,0(CP)
JUMPN 5,MRGH1 ;DONT WALK ON CURRENT STACKS
MOVE 6,1(6) ;LOOK AT END +1
TLC 6,STKHOL
TLNE 6,-1 ;HOLE?
JRST MRGH1 ;NO
ADDI 5,0(6) ;ADD LENGTH TO TOTAL
JRST MRGH2
MRGH1: JUMPE 5,MRGH3 ;QUIT IF NO HOLE AT ALL
MOVEI 6,0(5) ;MARK HOLE BEGINNING
HRLI 6,STKHOL
MOVEM 6,1(4)
MRGH3: MOVEI 4,0(4) ;CLEAR LEFT
JRST @MRGHX
U MRGHX
;COPY FRAME EXTENSION BECAUSE USE WAS > 0
;CALL WITH JSP 7, ; BEG FRAME IN 3, CPO OF FRAME IS OK
;RETURN WITH NEW BEG IN 3, PRESERVE AC1
;UPDATE CF, CP, PP, ICPC, IPPC
ECOP: INTOFF
HLRE 5,CP ;# LOCS LEFT ON CURRENT CP
MOVN 5,5
GETCPO 2,3 ;END OF FRAME
JSYS CPCOP ;COPY CP PART
JRST CPFUL ;NO SPACE
SKIPE BR ;IS THERE AN ACTIVE SWAPPED GUY?
CAME 3,LSTSWF ;YES, IS HE THE ONE BEING COPIED?
JRST .+4 ;NO
JSYS SWPFIX ;YES, FIX THE ORIGINAL
MOVEM 4,LSTSWF ;AND MAKE THE COPY BE THE CURRENT GUY
MOVS BR,4(3) ;RETRIEVE BR FROM THE FIXED ORIGINAL
HRRZS USEWD(4) ;USE OF COPY = 0
GETFLG 5,4
HRRZM 4,CF ;RESET CF
CAIE 5,PPR ;WAS FLG = PPR
JRST ECOP1
MOVEI 5,PPRC ;YES - CHANGE TO PPRC
SETFLG 5,4
ECOP1: HLRE 5,PP
MOVN 5,5
GETNAR 2,4
ADD 2,0(4) ;PTR TO LAST ARG
MOVSI 3,1
ADDM 3,1(2) ;INCREMENT CXT
GETPPI 3,4
ADDI 3,1 ;TEMS BEGIN AT PPI +1
GETPPO 2,4 ;END TEMS
JSYS PPCOP
JRST PPFUL ;REALLY FULL
HRRZ 3,CF
SUBI 4,1
SETPPI 4,3 ;RESET PPI
INTON
JRST 0(7)
;COPY CP PART OF EXTENSION BECAUSE OF EVERFLOW OR NO
;ROOM TO RUN, CF IS CURRENT FRAME (I.E. BEG)
;AND CURRENT CP IS END; RET NEW POS IN 3,AND
;UPDATE CF IF PERTINENT, CP AND ICPC UPDATED, SKIPS IF OK
;TERMINAL INTERRUPTS MUST BE OFF
ECOPCO: SKIPG 3,CF
MOVEI 3,1(3) ;NEG MEANS NOT REAL FR.(AND ONE LESS)
SETZ 5, ;KNOW CP IS FULL
MOVEI 2,0(CP)
JSYS CPCOP
JRST 0(7) ;FULL - NO SKIP
HRRZ 5,PPT ;LENGTH
HRLI 5,STKHOL ;MARK ORIG. AS HOLE
MOVEM 5,0(3)
MOVEI 3,0(4) ;NEW BEG.
JUMPE BR,ECPO3
MOVE 4,LSTSWF
CAMN 4,CF
HRRM 3,LSTSWF
ECPO3: HRRM 3,CF
SKIPG CF
JRST ECPO2
CAILE 3,-FLGWD(CP)
JRST 1(7) ;PARTIAL FRAME
ECPO1: GETFLG 4,3
MOVEI 5,PPRC
CAIN 4,PPR
SETFLG 5,3 ;RESET PPR TO PPRC
JRST 1(7)
ECPO2: SOS CF
JRST 1(7) ;WASNT REAL FRAME
;COPY PP PART OF AN EXTENSION BECAUSE OF PP OVF OR NO ROOM TO RUN
ECOPPO: SKIPG 3,CF
SKIPA 4,OPP ;NOT REAL FRAME - GET PP FROM OPP
GETPPI 4,3 ;PTR TO FRST TEM -1
SKIPN 4
GETBAS 4,3 ;PPI=0 MEANS PARTIAL FRAME
MOVEI 3,1(4)
MOVEI 2,0(PP)
SETZ 5,
JSYS PPCOP
JRST 0(7) ;FULL - NOSKIP
HRRZ 5,PPT ;MARK ORIG AS HOLE
JUMPE 5,EPPO2 ;IF IT EXISTED
HRLI 5,STKHOL
MOVEM 5,0(3)
EPPO2: SKIPG 3,CF ;REAL FRAME?
JRST EPPO3 ;NO -
SUBI 4,1 ;YES - UPDATE PPI
GETPPI 2,3
JUMPE 2,EPPO1 ;IF IT WAS PERTINENT
SETPPI 4,3
CAIN 2,0(FF)
HRRI FF,0(4) ;UPDATE FF IF PERTINENT
JRST ECPO1
EPPO1: SETBAS 4,3 ;PPI 0 MEANS HALF COMPLETED FN CALL
JRST ECPO1 ;..SO COPY FROM BEG ARGS AND UPDATE
EPPO3: HRRM 4,OPP ;NOT REAL FRAME - KEEP OPP
SOS OPP ;UP TO DATE
JRST 1(7)
;FLFR RELEASES FRAME - FRAME IN 2
;CLOBBERS 4,5,6
;ALSO NEEDS CONTROL STACK BUT NO P-STACK
;RET WITH LAST FRAME FLUSHED FROM C CHAIN IN 2
;RELSTK(POS) - NULLIFY STK PTR AND RELEASE STORAGE - PRESERVE AC1,3
RELSTK: STE 1,STKP
RET ;NOT STK PTR - IGNORE
MOVEI 2,0
EXCH 2,0(1) ;SET CONTENTS TO 0
FLFR: INTOFF
CALL FLFRA
INTON
RET
FLFRA: STE 2,STACK
RET ;CONTENTS ALREADY DEAD
JUMPE 2,.+2
CAMN 2,KNIL
POPJ CP,
GETUSE 5,2
SOJL 5,FLFR1
SETUSE 5,2 ;USE > 0
POPJ CP, ;DECREMENT AND QUIT
FLFR1: GETNAR 5,2
ADD 5,0(2) ;GET CXT
HLRZ 4,1(5)
SOJL 4,FLFR2
HRLM 4,1(5) ;CXT>0, DECREMENT
JRST FLEXT ;AND GO FLUSH EXTENSION
FLFR2: PUSH CP,0(2) ;USE=0,CXT=0 - FLUSH EVERYTHING
CALL FLEXT ;FLUSH EXTEN. FIRST (HOLES MAY MERGE)
POP CP,4 ;BEG ARGS -1
LDB 5,[POINT NARSIZ,4,17]
LDB 6,[POINT NFRESZ,4,8] ;# FREE VARS
ADDI 5,1(6) ;#ARGS+#FREE+1 IS BASIC FR. SIZE
JSYS MRGHOL ;FLUSH BASIC FRAME
GETAL 5,2
GETCL 2,2 ;CHEAT! LINKS STILL THERE AFTER FLUSH
CAIN 2,0(5) ;CLINK=ALINK?
JRST FLFRA ;YES - GO ROUND AGAIN
HRLM 2,0(CP)
MOVEI 2,0(5)
CALL FLFRA ;NO - FLUSH A CHAIN TOO
HLRZ 2,0(CP) ;THEN DO C
JRST FLFRA
FLEXT: GETPPO 5,2
GETPPI 4,2
SKIPN 4
GETBAS 4,2
SUBI 5,0(4)
SKIPE 5
JSYS MRGHOL ;MARK TEMS DELETED
GETCPO 5,2 ;NOTE - ONLY WORKS FOR STATIC FRAMES!
SUBI 5,-1(2)
MOVEI 4,-1(2)
JSYS MRGHOL ;MARK CP PART DELETED
RET
;LINKED FUNCTION CALL UUO
;LNCALL #ARGS,P
;P: HCCALBITS,,DEF
;P+1: NAME,,HCCALQ OR EXCALQ OR CCALC
ALCALQ: PUSH PP,1 ;ENTRY TO PUSH AC1 FIRST
LCALQ: LDB 1,UUACP
LCALQ2: MOVEI 2,.+1 ;MAKE FRAME
JRST EFNCAL
PUSHJ CP,.+1 ;XCT'D
MOVE 2,@40
EXCH 2,40 ;DEF TO 40
MOVE 3,1(2)
HLRZ 2,3 ;FN-NAME
JRST 0(3)
CCALC: JRST @40
;ENTRY SEQUENCE FOR EXPR'S
LAMCAL: POP PP,2 ;CALL OPEN LAM - GET EXPR
SUBI 1,1 ;DECR. # ARGS NOW
SKIPA 3,2
EXCALQ: HRRZ 3,40
CAMN 3,KNIL
JRST EXILL
CARA 5,3
CAME 5,KLAM
CAMN 5,KNLA
JRST EXCLM
EXILL: PUSH PP,2 ;FN NAME
HRRZ 3,CF ;FINISH FRAME
SETNAR 1,3
SETPPI PP,3
PUSH PP,2
MOVEI 6,-2
HRLI 6,PP
CALL LSTAR2
PUSH PP,1
LCALL KFALTA,2
RET
EXCLM: CDRA 3,3
CARA 4,3 ;VARIABLE LIST
CAMN 4,KNIL
JRST EXCLM3
STN 4,LIST ;LIST OR NIL?
JRST EXCLM6 ;YES
CAME 5,KNLA ;NO, LAMBDA OR NLAMBDA?
JRST EXCLM4
CAIGE 1,1 ;NLAMBDA - BIND TO ARG
PUSH PP,KNIL ;OR NIL IF NO ARG GIVEN
JRST EXCLM5
EXCLM4: ADDI 1,ASZ ;LAMBDA- BIND TO NUMBER OF ARGS
PUSH PP,1
EXCLM5: HRLM 4,0(PP)
EXCLM3: PUSH PP,2 ;SAVE NAME
MOVEI 1,0(PP)
HRRZ VP,-3(CP) ;SET VP AGAIN IN CASE PP MOVED
SUBI 1,1(VP) ;COMPUTE # ARGS STACKED
HRLM 1,-3(CP) ;SAVE # ARGS
HRLM PP,-2(CP) ;SAVE PPIN
CDRA 1,3 ;FORM TO BE EVALED
JRST PROGN ;GO EVAL FORMS
EXCLM6: HRRZ 6,-3(CP)
EXCLM2: CAMN 4,KNIL ;FINISHED BINDINGS?
JRST EXCLM3 ;YES
CARA 5,4
CDRA 4,4
SKIPG 1
JRST EXCLM7
HRLM 5,1(6)
SUBI 1,1
AOJA 6,EXCLM2
EXCLM7: PUSH PP,KNIL
HRLM 5,0(PP)
JRST EXCLM2
;ENTRY SEQUENCE FOR SWAPPED FUNCTIONS
SBCALQ: JSYS SWPFIX ;FIX UP PREVIOUS SWAP FRAME
MOVE BR,CF ;SET LSTSWF TO CF
MOVEM BR,LSTSWF
HRL BR,40
CALL SWAPIN ;SWAPIN NEW GUY
PUSH CP,[0] ;PUT ON STUFF FOR FIXUP
CALL 2(BR) ;BR POINTS TO HEADER, NOT 1ST INST.
SWPRET: SETZ BR, ;RETURN FROM SWAPPED FN.
SUB CP,BHC+1
RET
;COMPILED FUNCTION ENTRY ROUTINE
;AC'S: 1 - # ARGS GIVEN (FROM CALLING FN)
; 2 - FN NAME
; JSP 7,ENTERF
; XWD # ARGS EXP'D, FN TYPE
; XWD # FREE, VAR NAMES ADR
ENTERF: HRRZ 3,0(7) ;FN TYP
CAIN 3,2
JRST ENT7 ;LAMBDA ATOM
HLRZ 6,0(7) ;# ARGS EXPECTED
HRLM 6,-3(CP) ;# ARGS EXPECTED
SUBI 1,0(6) ;DIFFERENCE OF # GIVEN AND # EXPECTED
JUMPE 1,ENT2 ;EQUAL
JUMPG 1,ENT1 ;TOO MANY GIVEN
PUSH PP,KNIL ;TOO FEW GIVEN, USE NIL
AOJL 1,.-1
ENT2: MOVNI VP,1(6)
MOVSI VP,0(VP)
PUSH PP,2 ;STORE FN NAME
HRR VP,-3(CP) ;BEG. ARGS -1(MAY HAVE MOVED)
ENT21: HLRZ 5,1(7) ;# FREE VARS
JUMPE 5,ENT22
MOVSI 4,0(5) ;STORE # FREE
LSH 4,11
IORM 4,-3(CP)
ENT22: ADDI 5,0(6) ;# ARGS + # FREE
HRRZ 6,1(7) ;ADR. VAR NAMES
MOVN 5,5 ;ENTER HERE FROM ENTERB
HRLI 6,0(5)
ENT3: AOBJP VP,ENT4
MOVE 1,0(6) ;VAR NAME
TLNN 1,-1 ;LH NON-ZERO MEANS LOCAL VAR(UNNAMED)
HRLM 1,0(VP) ;TO LEFT OF WORD ON STACK
AOBJN 6,ENT3
ENT4: JUMPG 6,ENT6 ;NO FREE VARS
ENT5: HRRZ 1,0(6) ;FREE VAR NAME
HRRZ 2,CF
GETAL 2,2 ;BEGIN AT ALINK OF THIS FN
CALL PPLOK2 ;TO SEARCH STACK
JFCL ;NOT ON STACK (DOESNT MATTER
PUSH PP,1 ;PUT LOCATION OF BINDING ON STACK
AOBJN 6,ENT5
ENT6: HRLM PP,-2(CP) ;SAVE PPIN
HRRZ VP,-3(CP) ;LOAD VP - MAY HAVE CHANGED.
JRST 2(7) ;GO EXECUTE FUNCTION
ENT1: SUB PP,BHC(1) ;FLUSH EXTRA ARGS
JRST ENT2
ENT7: MOVEI 4,ASZ(1)
PUSH PP,4 ;# ARG GIVEN TO STACK
MOVEI 4,1(1)
HRLM 4,-3(CP) ;ARGS STACKED IS GIVEN + 1
MOVEI 6,1
PUSH PP,2
MOVEI VP,-2(PP) ;PTR TO THE BOUND ARG
HRLI VP,-2
JRST ENT21
;ENTERB, ANALOGOUS TO ENTERF BUF FOR SWAPPED BLOCKS.
;THE ONLY THING THAT HAS TO BE DONE DIFFERENTLY FOR SWAPPED CODE
;IS THAT THE VAR NAMES ADDR MUST BE RELOCATED, I.E. BR ADDED IN,
;AND THE LOCATION OF THE # OF ARGS IS NOW 2 MORE PLACES BACK UP
;THE STACK, I.E., -5(CP) INSTEAD OF -3(CP).
ENTERB: HRRZ 3,0(7) ;FN TYP
CAIN 3,2
JRST ENTB7 ;LAMBDA ATOM
HLRZ 6,0(7) ;# ARGS EXPECTED
HRLM 6,-5(CP) ;# ARGS EXPECTED
SUBI 1,0(6) ;DIFFERENCE OF # GIVEN AND # EXPECTED
JUMPE 1,ENTB2 ;EQUAL
JUMPG 1,ENTB1 ;TOO MANY GIVEN
PUSH PP,KNIL ;TOO FEW GIVEN, USE NIL
AOJL 1,.-1
ENTB2: MOVNI VP,1(6)
MOVSI VP,0(VP)
PUSH PP,2 ;STORE FN NAME
HRR VP,-5(CP) ;BEG. ARGS -1(MAY HAVE MOVED)
ENTB21: HLRZ 5,1(7) ;# FREE VARS
JUMPE 5,ENTB22
MOVSI 4,0(5) ;STORE # FREE
LSH 4,11
IORM 4,-5(CP)
ENTB22: ADDI 5,0(6) ;# ARGS + # FREE
HRRZ 6,1(7) ;ADR. VAR NAMES
ADDI 6,(BR) ;HERE'S THE EXTRA ADDI
MOVN 5,5
HRLI 6,0(5)
BENT3: AOBJP VP,BENT4
HRRZ 1,0(6) ;VAR NAME
HRLM 1,0(VP) ;TO LEFT OF WORD ON STACK
AOBJN 6,BENT3
BENT4: JUMPG 6,BENT6 ;NO FREE VARS
BENT5: HRRZ 1,0(6) ;FREE VAR NAME
HRRZ 2,CF
GETAL 2,2 ;BEGIN AT ALINK OF THIS FN
CALL PPLOK2 ;TO SEARCH STACK
JFCL ;NOT ON STACK (DOESNT MATTER
PUSH PP,1 ;PUT LOCATION OF BINDING ON STACK
AOBJN 6,BENT5
BENT6: HRLM PP,-4(CP) ;SAVE PPIN
HRRZ VP,-5(CP) ;LOAD VP - MAY HAVE CHANGED.
JRST 2(7) ;GO EXECUTE FUNCTION
ENTB1: SUB PP,BHC(1)
JRST ENTB2
ENTB7: MOVEI 4,ASZ(1)
PUSH PP,4 ;# ARG GIVEN TO STACK
MOVEI 4,1(1)
HRLM 4,-5(CP) ;ARGS STACKED IS GIVEN + 1
MOVEI 6,1
PUSH PP,2
MOVEI VP,-2(PP) ;PTR TO THE BOUND ARG
HRLI VP,-2
JRST ENTB21
;APPLY*(FN ARG1 ....)
APPLY.: SOJL 1,R ;1 HAS # ARGS TO APPLY*
HRRZ 2,1(VP) ;FN
PUSH CP,1 ;SAVE # ARGS
LDT 4,2
CAIN 4,LISTT
JRST APPLS
CAIE 4,ATOMT
JRST APPBAD ;ILLEGAL FN
MOVEI 1,0(2)
CALL ARGTYP ;GET ARGTYP
JRST APPBAD ;BAD DEF
APPL1: CAIN 1,3 ;N-LAMBDA AND NO-SPREAD?
JRST APPNS ;YES
APPS: POP CP,1 ;# ARGS
JUMPE 1,APPS1
MOVN 2,1
HRLI 2,0(2)
HRRI 2,2(VP)
HRRZ 3,0(2)
PUSH PP,3 ;MOVE ARGS DOWN
AOBJN 2,.-2
APPS1: HRRZ 2,1(VP)
STE 2,LIST ;WAS IT LAMDA
JRST APPC1
PUSH PP,2 ;YES - SAVE EXPR
MOVEI 2,CLAM-1 ;AND USE HOKEY CALL FOR NAME
AOJA 1,APPC1
APPC1: CALL EFNCAL ;JRST NOT USED CAUSE FRAME NEEDS THE CELL
RET
APPNS: POP CP,1 ;NO-SPREAD
MOVEI 6,1(1)
HRLI 6,VP
CALL LSTAR2 ;LIST ARGS
PUSH PP,1
MOVEI 1,1
JRST APPS1
APPLS: CARA 4,2
CAMN 4,KFNARG
JRST APPFNA
MOVEI 3,0(2)
CALL ARGT2
JRST APPBAD
JRST APPL1
APPBAD: POP CP,1
MOVEI 6,1(1)
HRLI 6,VP
CALL LSTAR2
PUSH PP,1(VP)
PUSH PP,1
APPB1: LCALL KFALTA,2
RET
; APPLY* OF FUNARG - PUNT BY LISTING ARGS AND CALLING APPLY
APPFNA: POP CP,1
MOVEI 6,1(1)
HRLI 6,VP
CALL LSTAR2
MOVEI 2,0(1)
HRRZ 1,1(VP)
JRST APPLY
;APPLY* FROM COMPILED CODE - STACK HAS FN AND ARGS - 1 HAS # ARGS
EVCC: MOVNI 6,0(1)
HRLI 6,PP
HRRZ 2,@6 ;GET FN
PUSH PP,2 ;AND SAVE IT
PUSH CP,1 ;SAVE # ARGS
LDT 4,2
CAIN 4,LISTT
JRST EVCLS
CAIE 4,ATOMT
JRST EVCBAD
MOVEI 1,0(2)
CALL ARGTYP
JRST EVCBAD
CAIE 1,3
JRST EVCC1
POP CP,7
CALL EVCLA
SKIPA 1,[1]
EVCC1: POP CP,1
POP PP,2 ;FN
JRST EVAF7 ;CALL FN - AND RET TO POP OFF FN
EVCLS: MOVEI 3,0(2)
CARA 2,2
CAMN 2,KFNARG
JRST EVCFNA
CALL ARGT2
JRST EVCBAD ;BAD EXPR
CAIE 1,3
JRST EVCLM1
POP CP,7 ;NO-SPREAD
CALL EVCLA
SKIPA 1,[1]
EVCLM1: POP CP,1
MOVEI 2,CLAM-1 ;HOKEY FN NAME
AOJA 1,EVAF7 ;GO CALL W/ 1 MORE ARG
EVCFNA: POP CP,7 ;FUNARG
CALL EVCLA ;PUNT - LIST ARGS
POP PP,1
POP PP,2
SUB PP,BHC+1
JRST APPLY
;LIST ARGS AND FLUSH FROM STACK
EVCLA: HRRZ 1,KNIL
JUMPE 7,EVCLAX ;NO ARGS
EVCLA1: MOVEI 2,0(1)
POP PP,1
EXCH 1,0(PP) ;GET ARG AND SAVE FN
CALL CONS
SOJG 7,EVCLA1
EVCLAX: EXCH 1,0(PP) ;SAVE LIST AND GET FN
PUSH PP,1 ;SAVE FN AGIN
RET
EVCBAD: POP CP,7
CALL EVCLA
SUB PP,BHC+1
JRST APPB1
;CONSTRUCT LIST OF ARGS
LIST: MOVEI 6,0(1)
HRLI 6,VP
LSTAR2: JUMPLE 1,FALSE ;ENTRY WITH PTR TO LAST ARG IN 6
MOVEI 7,0(1) ;COUNT
SKIPA 2,KNIL ;START WITH NIL
LSTAR1: MOVEI 2,0(1) ;LIST SO FAR
HRRZ 1,@6 ;NEXT ELEMENT
CALL CONS
SUBI 6,1
SOJG 7,LSTAR1
RET
;LIST FROM COMPILED CODE - TAKES ARGS OFF STACK
LIST3: MOVEI 6,3
JRST CLISTA
LIST4: MOVEI 6,4
JRST CLISTA
LIST2: MOVEI 1,2 ;ENTRY TO LIST 2 ELEMENTS
CLIST: JUMPLE 1,FALSE
MOVEI 6,0(1)
CLISTA: SKIPA 2,KNIL
CLIST1: MOVEI 2,0(1)
POP PP,1
CLIST2: CALL CONS
SOJG 6,CLIST1
RET
ALIST4: MOVEI 6,4 ;LIST 4 ELEMS, AND PUSH AC1 FIRST
JRST ALIST
ALIST3: MOVEI 6,3
JRST ALIST
ALIST2: MOVEI 6,2
ALIST: HRRZ 2,KNIL
JRST CLIST2
;STUFF FOR BLOCK COMPILER
;REBIND FREE VARS
; CALLED JSP 7,REBIND
; F,,P F REL.LOC. FREE VAR - P LOC NEW BINDING
;P IS LESS OR EQ 0 IF BINDING ON PP, GTR 0 IF ON VP
REBIND: HRRZ 2,CF
GETPPI FF,2
MOVEI 3,0(PP)
SUBI 3,0(FF)
HRLI 3,FF ;FF,,# PTEMS
HRLI 2,FF
REB4: HLR 2,0(7)
TRNE 2,777000
JRST REB1
HRRE 1,0(7)
JUMPG 1,REB2
ADD 1,3 ;STORE LOC OF BINDING W/R TO FF
REB3: EXCH 1,@2
PUSH CP,1
AOJA 7,REB4
REB2: ADDI 1,0(VP)
JRST REB3
REB1: PUSH CP,7 ;LEAVE RETURN ON STACK FOR UNBIND
JRST @7
;UNBIND CALLED JSP 7,UNBIND
UNBIND: HRRZ 2,CF
GETPPI FF,2
POP CP,3 ;ADDR TABLE END LEFT BY REBIND
MOVSI 2,FF
UNBN1: HLR 2,-1(3)
TRNE 2,777000
JRST 0(7)
POP CP,@2
SOJA 3,UNBN1 ;NOTE THAT AC1 PRESERVED
URET02: JSP 7,UNBIND
URET01: JSP 7,UNBIND
RET
URET12: JSP 7,UNBIND
URET11: JSP 7,UNBIND
URET10: SUB PP,BHC+1
POPJ CP,
URET22: JSP 7,UNBIND
URET21: JSP 7,UNBIND
URET20: SUB PP,BHC+2
POPJ CP,
URET32: JSP 7,UNBIND
URET31: JSP 7,UNBIND
URET30: SUB PP,BHC+3
POPJ CP,
URET42: JSP 7,UNBIND
URET41: JSP 7,UNBIND
URET40: SUB PP,BHC+4
POPJ CP,
URET52: JSP 7,UNBIND
URET51: JSP 7,UNBIND
URET50: SUB PP,BHC+5
POPJ CP,
URET62: JSP 7,UNBIND
URET61: JSP 7,UNBIND
URET60: SUB PP,BHC+6
POPJ CP,
URET72: JSP 7,UNBIND
URET71: JSP 7,UNBIND
URET70: SUB PP,BHC+7
POPJ CP,
;STUFF FOR BLOCK COMPILER
;BLKENT AT BEGINNING OF BLOCK TO SET UP ARGS AND CALL
;THE RIGHT SUBFN
;CALLED JSP 7,BLKENT
; #FREE,,ADDR NAMES FREE VARS THAT ARE LOOKED UP
; #FREE,,ADDR NAMES FREE VARS THAT ARENT LOOKED UP
; -#ENTRIES,,ADDR NAMES
; LOCS OF SUBFNS FOLLOW
SBLKNT: SKIPA 4,BR ;SWAPPED - RELOCATION IN 4
BLKENT: SETZ 4, ;RELOCATION 0
HRRZ 5,0(7)
MOVE 6,1(7)
TLNE 6,-1
PUSH PP,5 ;IF LOCALFREEVARS, SAVE ADR NAMES
HLLZ 6,0(7) ;LOOK UP FREE VARS
JUMPE 6,BLKEN4
MOVN 6,6
HRR 6,0(7) ;ADDR LITS
ADDI 6,0(4) ;RELOCATE
PUSH CP,4
BLKEN3: HRRZ 1,0(6) ;VAR NAME
HRRZ 2,CF
GETAL 2,2
CALL PPLOK2
JFCL
PUSH PP,1 ;STORE BINDING LOCS AT BEG. OF P-TEMS
AOBJN 6,BLKEN3
POP CP,4
BLKEN4: HLRZ 6,1(7)
JRST .+2
PUSH PP,IFTRAP ;SET TO TRAP ON REF
SOJGE 6,.-1
HRRZ 1,CF
MOVE 3,2(7)
TLNN 3,-1 ;ANY ENTRIES?
JRST BLKEN1 ;NO - ARGS ARE IN THIS FRAME
MOVEI 2,0(1)
MOVNI 1,1 ;YES - ARGS IN PRIOR FRAME
CALL STKNTH ;FIND THE CALLER OF THE BLOCK
BLKEN1: MOVE 6,0(1) ;BASIC FRAME PTR
TLZ 6,NARM1 ;MASK FOR NON-ARG STUFF
TLC 6,-1
JRST .+3
HRRZ 3,0(6)
PUSH PP,3
AOBJN 6,.-2
HRRZ FF,CF ;SET FF
MOVSI 3,400000
IORM 3,NARWD(FF) ;SET HI BIT FOR BLOCKFRAME
GETPPI FF,FF
MOVE 3,2(7)
TLNN 3,-1
JRST 3(7) ;NO ENTRIES
ADDI 3,(4) ;RELOCATE.
HRRZ 1,1(VP) ;THE NAME OF DESIRED ENTRY
HRLI 2,4 ;RELOCATE BY INDEXING OFF AC2.
BLKEN2: ADDI 7,1
HRRZ 5,0(3)
HRR 2,2(7)
CAIN 1,0(5)
JRST @2 ;C(2) = ADDR(4) SO IT'S RELOCATED.
AOBJN 3,BLKEN2
RET ;SHOULD BE ERROR
;BLKAPPLY MOVEI 2,**BLKENT ENTRY VECTOR
; PUSHJ CP,BLKAPP
BLKAPP: CAIE 2,10(BR) ;CALLED FROM SELF-RELOCATING CODE?
TRZA 5,-1 ;NO, SO "RELOCATE" BY 0.
HRRZI 5,(BR) ;YES, RELOCATE BY C(BR)
HRRZ 3,-1(PP) ;GET FN NAME
MOVE 6,0(2)
ADDI 6,(5) ;RELOCATE
;NOTE ON THE CAIN AT BLKAPP: THE VALUE 7 DEPENDS ON THE FACT THAT
;THE ENTRY VECTOR (**BLKENT) IS ALWAYS THE 7TH WORD OF A
;BLOCK, WHETHER SWAPPED OR NOT, AND IF SWAPPED, THE ABOVE CALLING
;SEQUENCE IS ACTUALLY
; MOVEI 2,**BLKENT(BR)
; PUSHJ CP,BLKAPP
;THIS IS A CROCK BUT IT'S FASTER THAN DOING A RANGE CHECK
;ON THE RIGHT HALF OF 0(CP) USING CBRANG AND CBRANG+1, WHICH
;IS THE SUPERCLEAN WAY. JWG.
BLKAP1: CAMN 3,0(6)
JRST BLKAPG
ADDI 2,1
AOBJN 6,BLKAP1
POP PP,2 ;NOT IN BLOCK, DO APPLY
POP PP,1
CALL APPLY
BLKAP5: HRRZ FF,CF ;RESTORE FF
GETPPI FF,FF
RET
BLKAPG: HRRZ 4,1(2) ;ADDR OF SUBFN
ADDI 4,(5) ;RELOCATE
HLRZ 3,-1(4) ;# ARGS NEEDED
POP PP,1
SUB PP,BHC+1
HRRZ 2,-1(4) ;CHECK FN TYP
CAIE 2,3 ;LAMA?
JRST BLKAP4
PUSH PP,1 ;YES - ARGLIST IS ARG
JRST 0(4)
BLKAP3: STE 1,LIST ;SPREAD ARGS
JRST BLKAP2
HRRZ 2,0(1)
PUSH PP,2
HLRZ 1,0(1)
BLKAP4: SOJGE 3,BLKAP3
JRST 0(4) ;GO TO SUBFN
BLKAP2: PUSH PP,KNIL ;NOT ENUF ARGS GIVEN, USE NIL
SOJGE 3,.-1
JRST 0(4)
;BLKAPPLY* CALLED MOVEI 1,#ARGS(INCL FN NAME)
; MOVEI 2,**BLKENT
; PUSHJ CP,BLKAP*
BLKAP.: CAIE 2,10(BR) ;DITTO BLKAPP, FOR BLKAPPLY*
TRZA 5,-1
HRRZI 5,(BR)
MOVEI 3,0(PP)
SUBI 3,-1(1)
HRRZ 3,0(3) ;THE FN
MOVE 6,0(2)
ADDI 6,(5)
BLKA.1: CAMN 3,0(6)
JRST BLK.G
ADDI 2,1
AOBJN 6,BLKA.1
MOVE 2,KAPP.
CALL EFNCAL
JRST BLKAP5
BLK.G: HRRZ 4,1(2)
ADDI 4,(5)
HLRZ 3,-1(4)
SUBI 1,1(3)
JUMPL 1,BLKA.2
SUB PP,BHC(1) ;TOO MANY
BLKA.3: PUSHJ CP,0(4) ;CALL SUBFN
JRST EVNA1 ;FLUSH FN NAME AND RETURN
BLKA.2: PUSH PP,KNIL
AOJL 1,.-1
JRST BLKA.3
;ARG(VAR N) GET NTH COMPONENT OF NON-SPREAD VAR
ARGN: CALL ARGNP
HRRZ 1,0(1)
RET
;SETARG(VAR N VALUE)
SETARG: CALL ARGNP
PUSH PP,1
HRRZ 1,3(VP)
CALL EVAL
POP PP,2
HRRM 1,0(2)
RET
ARGNP: CALL PPLOOK
JRST ARGNER ;NOT ON STACK - ERROR
PUSH PP,1 ;SAVE PSTACK POS. OF VAR
HRRZ 1,2(VP)
CALL EVAL
CALL IUNBOX
POP PP,3
HRRZ 2,0(3) ;# ARGS BOUND TO VAR
CAILE 1,-ASZ(2)
JRST ARGNER
SUBI 1,1-ASZ(2)
ADDI 1,0(3)
RET
ARGNER: HRRZ 1,1(VP)
ERROR1 33,RESET
;EVAL
EVAL: CAME 1,KNIL ;FAST CHECK FOR NIL AND NOBIND
CAMN 1,KNOB
RET ;EVALS TO SELF
LDT 2,1 ;GET TYPE OF THIS POINTER
CAIN 2,LISTT ;LIST?
JRST EVAF ;YES
CAIN 2,ATOMT ;ATOM?
JRST EVAT ;YES
HRRZ 2,EVATAB(2)
SKIPE 2 ;IS THERE A USER EVAL. FN FOR THIS TYPE?
CAIN 2,-1
RET ;NO - ITEM EVALS TO ITSELF
PUSH PP,2 ;YES -USE APPLY* TO EVAL THE ITEM
PUSH PP,1 ;THE ITEM
MOVEI 1,1
CALL EVCC
RET
EVAT: CALL PPLOOK ;LOOKUP ATOM ON STACK
JRST EVAA1 ;NOT ON STACK
HRRZ 1,0(1) ;GET VALUE FROM STACK
RET
EVAA1: CARA 2,1 ;GET VALUE CELL
CAME 2,KNOB ;BOUND?
JRST R2 ;YES, RETURN VALUE
EVFAU: PUSH PP,1 ;NO, CALL FAULTEVAL
LCALL KFAULT,1
RET
;FAULTEVAL IF NOT USER SUPPLIED
FAULTX: ERROR1 24,R
;APPLY AND EVAL OF NON-ATOMIC FORM
APPLY: EXCH 1,2
PUSH PP,[XWD APBLIP,0] ;SUPRESS EVALUATION OF ARGS
HRRM 2,0(PP)
JRST APPLY1
APPLY2: PUSH PP,2 ;FROM FUNARG
MOVEI 2,0(2)
JRST APPLY1
EVAF: PUSH PP,[XWD EVBLIP,0] ;SAYS DOING EVAL & HAVE WHOLE FORM
HRRM 1,0(PP) ;SAVE FORM FOR W.T.
CARA 2,1 ;NON-ATOMIC FORM, GET CAR
CDRA 1,1
APPLY1: TLZ F,EVLFLG
PUSH PP,1 ;ARG-LIST
PUSH PP,2 ;FN
EVNC5: LDT 3,2 ;GET TYPE OF CAR
CAIN 3,LISTT ;LIST?
JRST EVNAC ;YES, EVAL OF NON-ATOMIC CAR OF FORM
CAIE 3,ATOMT ;ATOM?
JRST UDF ;NO, ILLEGAL
MOVEI 1,0(2)
HRRZ 3,1(2)
CAMN 3,KNIL
JRST EVNC4 ;NO DEF, TRY VALUE
CALL ARGTYP ;ARGS ARE EVAL/NOEVAL, SPREAD/NOSPREAD
JRST UDF ;DEF EXISTS BUT IS BAD
POP PP,2
HRLI 2,FNBLIP(1) ;KEEP ARGTYPE BITS WITH FN NAME
EVNC2: POP PP,1
HLRZ 3,0(PP) ;EVAL-APPLY FLAG
PUSH CP,[0] ;INIT # ARGS
TLNE 2,1 ;IS THIS NO-EVAL AND NO-SPREAD?
TLNN 2,2
JRST EVAF3 ;NO, GO MAP ARG LIST
HRLI 1,AVBLIP
PUSH PP,1 ;YES, USE CDR OF FORM AS ARG
AOS 0(CP)
JRST EVAF6
EVAF3: TRNE 3,APBLIP ;IS THIS AN APPLY?
TLO 2,1 ;YES, DON'T EVAL ARGS
EVAF1: STE 1,LIST ;ANY LIST LEFT?
JRST EVAF2 ;NO
HRLI 1,PRBLIP
PUSH PP,1 ;YES, SAVE IT
PUSH PP,2 ;AND FN NAME
CARA 1,1 ;GET NEXT ARG
TLNN 2,1 ;EVAL IT?
CALL EVAL ;YES
HRLI 1,AVBLIP ;FLAG ARGVAL FOR WT
POP PP,2
EXCH 1,0(PP) ;PUT ARG ON STACK
AOS 0(CP)
CDRA 1,1 ;GET REST OF LIST
JRST EVAF1
EVAF2: CAME 1,KNIL
ERROR1 31,R ;CDR NOT LIST OR NIL - ERROR???
EVAF6: POP CP,1 ;GET NUMBER OF ARGS STACKED
MOVEI 2,0(2) ;CLEAR LEFT NAME
CAIE 2,CLAM-1 ;HOKEY FN?
JRST EVAF7
ADDI 1,1 ;YES - 1 MORE ARG FOR NOW
POP CP,3 ;THE EXPR
PUSH PP,3
EVAF7: PUSHJ CP,EFNCAL ;CALL FN
EVNA1: SUB PP,BHC+1 ;FLUSH THE BLIP
RET
;NON-ATOMIC CAR OF FORM
EVNAC: CARA 3,2
CAMN 3,KFNARG
JRST EVNFA
MOVEI 3,0(2)
CALL ARGT2 ;IS LAMBDA/NLAMBDA?
JRST EVNC1 ;NO
MOVSI 2,0(1) ;ARGTYP BITS TO LH
HRRI 2,CLAM-1 ;HOKEY NAME FOR LAMBDA'S
POP PP,1 ;EXPR
PUSH CP,1 ;SAVE IT OUT OF THE WAY
JRST EVNC2 ;CONTINUE WITH EVAL
CLAM: CALL LAMCAL ;TO CALL OPEN LAMBDAS
EVNC1: MOVE 1,0(PP) ;GET CAR OF FORM
TLNE F,EVLFLG
JRST .+3
TLNE F,NACFLG ;WARRENS EXPERIMENT********
JRST UDF
CALL EVAL ;EVAL IT TO GET FN NAME
JRST EVNC6 ;CONTINUE WITH EVAL
;UNDEFINED ATOMIC CAR OF FORM
EVNC4: TLNE F,NACFLG
JRST UDF
MOVE 1,0(PP) ;ATOM
CALL PPLOOK ;LOOK ON STACK
JFCL 0 ;OR VALUE CELL
HRRZ 1,0(1)
EVNC6: CAMN 1,0(PP)
JRST UDF ;VALUE IS SELF - ERROR
CAME 1,KNIL
CAMN 1,KNOB
JRST UDF ;NIL OR NOBIND IS ERROR
EVNC3: MOVEM 1,0(PP) ;OTHERWISE, TRY AGAIN
MOVEI 2,0(1)
TLO F,EVLFLG
JRST EVNC5
UDF: MOVE 1,-2(PP) ;BLIP,,FORM
SUB PP,BHC+3
TLZE 1,EVBLIP
JRST EVFAU ;GO TO FAULTEVAL
TLZN 1,APBLIP
JRST UDF1
ADD PP,BHC+3
HRRZ 1,0(PP)
EXCH 1,-1(PP) ;FAULTAPPLY WANTS FN, ARGS
HRRZM 1,0(PP) ;... WE HAVE ARGS,FN
LCALL KFALTA,2
JRST EVNA1 ;FLUSH BLIP
UDF1: HRRZ 2,2(PP) ;FUNARG IN EVAL - DONT HAVE FORM????
CALL CONS
JRST EVFAU
;FUNARG
EVNFA: CDRA 2,2
CDRA 2,2
CARA 2,2 ;POS
STE 2,STKP
JRST EVNFAB
MOVE 3,0(2) ;UNBOX
JUMPE 3,EVNFAB ;RELEASED PTR
PUSH CP,[EVNFA1] ;CLOSE OUT CURRENT FRAME
HRLM PP,0(CP)
HRRZ 1,CF
SETCPO CP,1
INTOFF
MOVSI 2,1
ADDM 2,USEWD(3) ;INCREM USE(FUNARG FRAME)
MOVEI 2,1(CP) ;MAKE A DUMMY FRAME
EXCH 2,CF
PUSH CP,PP
HRRZS 0(CP)
PUSH CP,3 ;ALINK
PUSH CP,2 ;CLINK
PUSH CP,HCRETC
PUSH PP,KNIL ;FRAME NAME
HRLM PP,-2(CP) ;SET PPI
INTON
GETPPO 3,1
MOVE 2,0(3) ;GET FUNARG FROM FORMER FRAME
CDRA 2,2
CARA 2,2 ;THE FN
HRRZ 1,-1(3) ;ARG-LIST
HLL 2,-2(3) ;OLD BLIP
TLZ 2,EVBLIP
CALL APPLY2
RET
EVNFA1: SUB PP,BHC+3
RET
EVNFAB: MOVEI 1,0(2)
JRST STKERR
NONAC: CAME 1,KNIL ;WARRENS EXPERIMENT*********
TLOA F,NACFLG
TLZ F,NACFLG
MOVEM F,TFLGS
RET
;ROUTINE TO SEARCH PARAMETER STACK FOR VARIABLE BINDING
;CALLED WITH ATOM IN 1
;SKIPS IF FOUND AND RETURNS POINTER TO STACK IN 1 & FRAME IN 2
;DOES NOT SKIP, RETURNS ATOM IN 1 IF NOT FOUND
;PPLOOK LOOKS BACKWARD FROM CURRENT FRAME IN CF
;PPLOK2 LOOKS BACKWARD FROM FRAME IN AC2
;NOTE NOW CLOBBERS AC5 WHERE DIDNT BEFORE
PPLOOK: HRRZ 2,CF ;USE CURRENT FRAME
PPLOK2: HRLI 3,4
PPLOK3: JUMPE 2,PPLKR ;CANT FIND
HRR 3,0(2) ;PTR TO FRST ARG -1
HLRE 4,NARWD(2) ;GET # ARGS
PPLK6: JUMPLE 4,PPLK4 ;NO ARGS OR BINDINGS EXIST IN EXT
PPLK9: TRNE 4,NARM1
JRST PPLKF ;HAS SOME FREE VARS
PPLK1: HLRZ 5,@3
CAIN 5,0(1)
JRST PPLK3 ;YES
SOJG 4,PPLK1 ;NO, COUNT ARGS
PPLK2: GETAL 2,2 ;ALINK
JRST PPLOK3
PPLK3: MOVEI 1,@3 ;ADDR OF BINDING
PPLK31: AOS 0(CP) ;GOOD, RETURN SKIPING
PPLKR: RET
PPLK4: JUMPE 4,PPLK2 ;NO ARGS AT ALL
GETPPI 4,2 ;SEARCH EXT. IF BLOCK FRAME
MOVEI 5,0(PP)
CAMN 2,CF
JRST PPLK10
GETPPO 5,2
PPLK10: HRRI 3,0(4)
SUBM 5,4
JUMPE 4,PPLK7
PPLK8: HLRZ 5,@3
CAIN 5,0(1)
JRST PPLK3
SOJG 4,PPLK8
PPLK7: HLRZ 4,NARWD(2)
TRZ 4,400000
HRR 3,0(2)
JUMPN 4,PPLK9
JRST PPLK2
PPLKF: IDIVI 4,1000
ADDI 3,1(5) ;FREE VARS START AT #ARGS+1
TLO 3,20 ;INDIRECT TWICE
PPLK5: CAIN 1,@3
JRST PPLKR ;BOUND IN ATOM
HLRZ 5,@3 ;SAME SEARCH LOOP AS ABOVE
CAIN 5,0(1)
JRST PPLK3 ;FOUND
SOJG 4,PPLK5
GETNAR 4,2 ;NOW GO DO BASIC ARGS
TLZ 3,20
HRR 3,0(2)
JUMPN 4,PPLK1
JRST PPLK2
;EVALV(VAR POS)
EVALV: MOVEI 1,0(2)
CALL STKGP
JUMPE 1,STKER2
MOVEI 2,0(1)
HRRZ 1,1(VP)
CALL PPLOK2
JFCL ;NOT ON STACK - DOESNT MATTER
HRRZ 1,0(1) ;GET VALUE
RET
;PUSH LIST FUNCTIONS
;INTERNAL STKPOS, 1 IS FN NAME, 2 IS HOW MANY
;-ALONG CLINK,+ ALINK, 3 IS UNBOXED STARTING FRAME
STKPOS: CAMN 1,KNIL ;FRST ARG NIL MEANS CF
JRST STKP4
MOVE 4,STKPC ;=GETCL
JUMPL 2,.+3
MOVE 4,STKPA ;=GETAL
MOVN 2,2
MOVEM 4,STKPX
STKP3: GETNAR 4,3
ADD 4,0(3)
HRRZ 4,1(4) ;NAME
CAIN 1,0(4)
JRST STKP1
STKP2: XCT STKPX ;GETCL OR AL
JUMPN 3,STKP3
SKIPA ;FAIL - RETURN 0
STKP1: AOJL 2,STKP2
MOVEI 1,0(3) ;RETURN UNBOXED POS
RET
STKP4: HRRZ 1,CF
JUMPLE 1,STKERR ;SHOULDNT HAPPEN
RET
STKPC: GETCL 3,3
STKPA: GETAL 3,3
U STKPX
;USER STKPOS(FN N IPOS OPOS)
USTKPO: CAMN 2,KNIL
SKIPA 1,[-1]
PIUNBX 2
PUSHN 1
HRRZ 1,3(VP)
CALL STKGP
JUMPE 1,STKER3 ;NO GOOD POS
MOVEI 3,0(1)
HRRZ 1,1(VP)
POPN 2
CALL STKPOS
CAMN 1,CF
JRST STKER3
HRRZ 2,4(VP)
JRST USTKN2 ;GO FOOL WITH OPOS
STKER1: SKIPA 1,1(VP)
STKER3: HRRZ 1,3(VP)
STKERR: ERROR1 23,RESET
STKER2: HRRZ 1,2(VP)
JRST STKERR
;CONVERT A POS ARGUMENT TO AN UNBOXED POS
STKGP: CAMN 1,KNIL ;NIL MEANS CURRENT
JRST STKGN
CAMN 1,KT ;T MEANS TOP
JRST STKGT
LDT 2,1
CAIN 2,STKPT
JRST STKGS
CAIN 2,ATOMT
JRST STKGA
CAIL 2,FLOATT
CAILE 2,SMALLT
JRST STKERR ;NONE OF ABOVE - ERROR
CALL IUNBOX
HRRZ 2,CF ;NUMBER - DO STKNTH (N CF)
JRST STKNTH
STKGT: HRRZ 1,CF ;FIND TOP COMTROL FRAME
STKGT1: GETCL 2,1
JUMPE 2,STKGR
MOVEI 1,0(2)
JRST STKGT1
STKGS: SKIPN 0(1) ;STACK POINTER WAS RELEASED
ERROR1 36,RESET
SKIPA 1,0(1) ;STACK POS - UNBOX
STKGN: HRRZ 1,CF ;CURRENT FRAME
STKGR: RET
STKGA: MOVNI 2,1 ;ATOM - DO STKPOS(ATOM -1 CF)
HRRZ 3,CF
JRST STKPOS
;INTERNAL STKNTH - 1 IS NUMBER, 2 IS UNBOXED POS
STKNTH: MOVE 3,STKPC ;=GETCL
JUMPL 1,.+3 ;FOR N <0
MOVE 3,STKPA ;=GETAL - FOR N>0
MOVN 1,1
MOVEM 3,STKPX
MOVEI 3,0(2)
JUMPE 1,STKN2 ;N=0 - JUST RETURN POS
STKN1: XCT STKPX ;FOLLOW APPROPRIATE LINKS
JUMPE 3,STKN2
AOJL 1,STKN1
STKN2: MOVEI 1,0(3)
RET
;USER STKNTH (N IPOS OPOS) N=0 WILL COPY IPOS INTO OPOS OR NEW
USTKNT: CAMN 1,KNIL
SKIPA 1,[-1] ;FIRST ARG NIL MEANS -1
CALL IUNBOX
PUSHN 1
HRRZ 1,2(VP)
CALL STKGP
JUMPE 1,STKER2 ;ERROR - BAD POS ARG
MOVEI 2,0(1)
POPN 1
CALL STKNTH
CAMN 1,CF
JRST STKER2 ;CANT BOX CF
HRRZ 2,3(VP)
USTKN2: STE 2,STKP
JRST USTKN1 ;OPOS IS IGNORED IF NOT STACK POINTER
MOVSI 3,1
INTOFF
SKIPE 1
ADDM 3,USEWD(1) ;INCREM USE
EXCH 1,0(2) ;PUT RESULT IN OLD BOX
EXCH 1,2 ;1 HAS OPOS, 2 HAS C(OPOS)
CALL FLFR ;FLUSH OPOS
INTON
SKIPN 0(1)
JRST FALSE ;POS NOT FOUND - RETURN NIL
RET
USTKN1: JUMPE 1,FALSE ;DITTO
JRST MKSTKP ;GO BOX RESULT
;STKSCAN(ATOM POS OPOS) - FIND BINDING OF ATOM - CHASE ALINKS
STKSCN: MOVEI 1,0(2)
CALL STKGP
JUMPE 1,STKER2 ;BAD POS
MOVEI 2,0(1)
HRRZ 1,1(VP)
CALL PPLOK2
JRST FALSE ;NOT ON STACK
STKSC2: TLZE 3,20
JRST STKSC1 ;PICKED UP THRU FREE PTR - BAD
MOVEI 1,0(2) ;RETURN FRAME IN WHICH BOUND
HRRZ 2,3(VP)
JRST USTKN2
STKSC1: HRRZ 1,1(VP)
CALL PPLK2 ;GO ON TILL REAL BINDING
JRST FALSE
JRST STKSC2
;STACK CLEARING FUNCTIONS
;RETFROM(POS VAL FLG)
RETFRM: CALL STKGP
JUMPE 1,STKER1 ;BAD POS
GETCL 2,1
JUMPE 2,STKER1 ;CANT RETFROM TOP LEVEL
HRRZ 2,3(VP) ;FLG
INTOFF
CAMN 2,KNIL
JRST RETF1
PUSH PP,1
HRRZ 1,1(VP) ;GET UNBOXED POS
CALL FLED1 ;RELEASE STKP (JUST DECR USE)
POP PP,1
RETF1: HRRZ 2,2(VP)
JRST RETU4 ;GO TO RETURN
FLED1: STE 1,STKP ;INTERNAL FLUSH OF ED
RET ;NOT STK PTR
MOVEI 2,0 ;SET TO 0
EXCH 2,0(1) ;GET CONTENTS
STE 2,STACK
RET ;ALREADY FLUSHED
MOVSI 3,-1 ;DECREM. USE OF FRAME
ADDM 3,USEWD(2) ;BUT DONT FLUSH CAUSE STILL NED IT
RET
;RETTO(POS VAL FLG)
RETTO: CALL STKGP
JUMPE 1,STKER1
HRRZ 2,3(VP) ;FLG
INTOFF
CAMN 2,KNIL
JRST RETT1
PUSH PP,1
HRRZ 1,1(VP) ;GET UNBOXED POS
CALL FLED1 ;RELEASE STKP (JUST DECR USE)
POP PP,1
RETT1: HRRZ 2,2(VP)
JSP 7,UNSTK ;UNWIND THE STACK
MOVE 3,1 ;MOVE THINGS FOR PPRC31
MOVE 1,2
JRST PPRC31 ;LET THE "RETURNER" DO THE REST
;ENVEVAL(FORM APOS CPOS AFLG CFLG)
;NOTE - OLD STKEVAL(POS FORM) BECOMES ENVEVAL(FORM POS 1)
;AND OLD RETEVAL(POS FORM) BECOMES ENVEVAL(FORM POS POS)
ENVEVL: HRRZ 1,3(VP) ;CPOS
CALL STKGP
JUMPE 1,STKER3 ;BAD POS
PUSH PP,1 ;SAVE UNBOXED POS
HRRZ 1,2(VP) ; APOS
CAIN 1,@3(VP) ;APOS EQ CPOS?
JRST ENVEV2 ;YES - AVOID DOUBLE SEARCH
CALL STKGP
JUMPE 1,STKER2 ;BAD POS
ENVEV3: INTOFF
MOVSI 3,1
CAME 1,0(PP) ;APOS EQUAL CPOS?
ADDM 3,USEWD(1) ;NO - INCREM USE(APOS)
PUSH PP,1 ;UNBOXED APOS
HRRZ 1,3(VP) ;GET BOXED BACK
HRRZ 2,5(VP) ;CFLG
CAME 2,KNIL
CALL FLED1 ;FLG T - FLUSH THE STK PTR&DECR. USE
HRRZ 1,2(VP) ;GET BOXED APOS AGAIN
HRRZ 2,4(VP) ;AFLG
CAME 2,KNIL
CALL FLED1 ;ALFG T - FLUSH STK PTR AND DECR USE
HRRZ 2,0(PP) ;UNBOXED APOS
HRRZ 1,-1(PP) ;CPOS
HRRZ 3,1(VP) ;FORM
MOVEM 3,ENVEVT ;SAVE OFF STACK
JSP 7,UNSTK ;INCR. USE(CPOS) & FLUSH FROM CF TO CPOS
MOVEI 3,1(CP)
MOVEM 3,CF ;SET CF BEFORE PUSH
PUSH CP,PP ;MAKE DUMMY FRAME
HRRZS 0(CP) ;0 ARGS
PUSH CP,2 ;ALINK
HRLM PP,0(CP) ;PPIN
PUSH CP,1 ;CLINK
PUSH CP,HCRETC ;FLG
PUSH PP,KNIL ;PHONEY NAME
HRLM PP,-2(CP) ;SAVE PPIN
MOVE 1,ENVEVT
INTON
JRST EVAL ;AND GO EVAL FORM
ENVEV2: HRRZ 1,0(PP) ;GET UNBOXED CPOS=APOS
JRST ENVEV3
HCRETC: XWD 0,PPRC
U ENVEVT
; ENVAPPLY (FN ARGS APOS CPOS AFLG CFLG)
ENVAPP: HRRZ 1,4(VP) ;CPOS
CALL STKGP
JUMPE 1,STKER4 ;BAD POS
PUSH PP,1 ;SAVE UNBOXED POS
HRRZ 1,3(VP) ; APOS
CAIN 1,@4(VP)
JRST ENVAP2
CALL STKGP
JUMPE 1,STKER3 ;BAD POS
ENVAP3: INTOFF
MOVSI 3,1
CAME 1,0(PP) ;APOS EQUAL CPOS?
ADDM 3,USEWD(1) ;NO - INCREM USE(APOS)
PUSH PP,1 ;UNBOXED APOS
HRRZ 1,4(VP) ;GET BOXED BACK
HRRZ 2,6(VP) ;CFLG
CAME 2,KNIL
CALL FLED1 ;FLG T - FLUSH THE STK PTR&DECR. USE
HRRZ 1,3(VP) ;GET BOXED APOS AGAIN
HRRZ 2,5(VP) ;AFLG
CAME 2,KNIL
CALL FLED1 ;ALFG T - FLUSH STK PTR AND DECR USE
HRRZ 2,0(PP) ;UNBOXED APOS
HRRZ 1,-1(PP) ;CPOS
HRRZ 3,1(VP) ;FN
HRL 3,2(VP) ;ARG LIST
MOVEM 3,ENVEVT ;SAVE OFF STACK
JSP 7,UNSTK ;INCR. USE(CPOS) & FLUSH FROM CF TO CPOS
MOVEI 3,1(CP)
MOVEM 3,CF ;SET CF BEFORE PUSH
PUSH CP,PP ;MAKE DUMMY FRAME
HRRZS 0(CP) ;0 ARGS
PUSH CP,2 ;ALINK
HRLM PP,0(CP) ;PPIN
PUSH CP,1 ;CLINK
PUSH CP,HCRETC ;FLG
PUSH PP,KNIL ;PHONEY NAME
HRLM PP,-2(CP) ;SAVE PPIN
HRRZ 1,ENVEVT
HLRZ 2,ENVEVT
INTON
JRST APPLY ;AND GO APPLY
ENVAP2: HRRZ 1,0(PP) ;GET UNBOXED CPOS=APOS
JRST ENVAP3
STKER4: HRRZ 1,4(VP)
JRST STKERR
;STKARG(N POS) - VALUE OF NTH ARG AT POS (WAS BEFORE BINDING OF)
STKARG: CALL STKAR1
HRRZ 1,0(1) ;VALUE
RET
STKANM: CALL STKAR1
HLRZ 1,0(1) ;ARG NAME
RET
;SETSTKARG(N POS VAL) - N NUM IS ARG#, N ATOME IS ARG NAME
SSTKAR: CALL STKAR1
SSTKA4: HRRZ 2,3(VP)
HRRM 2,0(1)
SSTKA2: MOVEI 1,0(2)
RET
;SETSTKARGNAME(N POS NAM)
SSTKAN: CALL STKAR1
HRRZ 2,3(VP)
HRLM 2,0(1)
JRST SSTKA2
STKAR1: LDT 3,1
CAIE 3,ATOMT
JRST STKAR2
CALL FRMSCN ;TRANSFORM ARG NAME TO NUMBER
CAMN 1,KNIL
JRST ILARG1 ;NO SUCH ARG THIS FRAME - ERROR
MOVEI 1,@3 ;LOC OF BINDING
RET
STKAR2: MOVEI 1,0(2)
CALL STKGP
JUMPE 1,STKER2
PUSH PP,1
HRRZ 1,1(VP) ;NUMBER OF ARG AT THIS POSITION
CALL IUNBOX
POP PP,7
JUMPLE 1,STKAR3 ;N NEG?
GETNAR 2,7
CAILE 1,0(2)
JRST ILARG1 ;N TOO BIG
ADD 1,0(7)
RET
STKAR3: JUMPE 1,ILARG1 ; ZERO IS ERRO
GETPPI 2,7
SUBM 2,1
GETPPO 2,7
CAMN 7,CF
MOVEI 2,0(PP)
CAILE 1,0(2)
JRST ILARG1 ; MAGNITUDE N EXCEEDS FRAME EXT. SIZE
HLRZ 2,0(1) ;GET LEFT
JUMPE 2,ILARG1 ; IS NOT A BINDING - ERROR
RET
STKNRG: CALL STKGP
JUMPE 1,STKER1
GETNAR 1,1 ;CHANGE FOR COMPILER?????????
JRST MKN
;STKNTHNAME(N IPOS)
STKNNM: CAMN 1,KNIL
SKIPA 1,[-1]
CALL IUNBOX
PUSHN 1
HRRZ 1,2(VP)
CALL STKGP
JUMPE 1,STKER2
MOVEI 2,0(1)
POPN 1
CALL STKNTH
JUMPE 1,FALSE
JRST STKNA1
;STKNAME(POS)
STKNAM: CALL STKGP
JUMPE 1,STKER1
STKNA1: GETNAR 2,1 ;# ARGS
ADD 2,0(1) ;BEG ARGS -1
HRRZ 1,1(2) ;FN NAME
RET
;FRAMESCAN (ATOM POS)
;GETS RELATIVE POSITION OF BINDING IN A FRAME - NIL IF NOT THERE
FRMSCN: MOVEI 1,0(2)
CALL STKGP
JUMPE 1,STKER2
HRRZ 2,1(VP)
HRLI 3,4
HLRE 4,NARWD(1) ;LIKE PPLOOK BU DONT GO OUTSIDE FRAME
FRMSC9: HRR 3,0(1)
JUMPLE 4,FRMSC4
FRMSC1: HLRZ 5,@3
CAIN 5,0(2)
JRST FRMSC2
SOJG 4,FRMSC1
JRST FALSE ;NOT IN THIS FRAME
FRMSC4: JUMPE 4,FALSE ;NO ARGS AT ALL
GETPPI 4,1 ;SEARCH EXT OF BLOCK FRAME
MOVEI 5,0(PP)
CAMN 1,CF
JRST FRMS10
GETPPO 5,1
FRMS10: HRRI 3,0(4)
SUBM 5,4
JUMPE 4,FRMSC7
FRMSC8: HLRZ 5,@3
CAIN 5,0(2)
JRST FRMSC3
SOJG 4,FRMSC8
FRMSC7: GETNAR 4,1
JRST FRMSC9
FRMSC2: SKIPA 1,4 ;REALTIVE ARG LOC
FRMSC3: MOVNI 1,0(4) ;NEGATIVE IF FRAME EXTENSION
ADDI 1,ASZ ;GUARANTEED SMALL
RET ;RETURN N , AND @3 HAS BINDING LOC
;FIND BLIP(TYP IPOS FLG)
;FLG T MEANS FIND HOW MANY AT POS (DOESNT GO OUT OF POS)
;FLG NUMBER MEANS FIND NTH ONE BEGINNING AT POS (NIL=0)
FNDEVL: PUSH PP,3 ;IN CASE CALLE D FROM BLIPSCAN
MOVE 4,[XWD -NBLIPS,BLIPTB]
FNDEVA: MOVE 5,0(4)
CAMN 1,0(5)
JRST FNDEVB
AOBJN 4,FNDEVA
MOVEI 4,0(1) ;NO SUCH BLIP, USE TYP AS IS
JRST .+3
FNDEVB: HLRZ 4,5
ANDI 4,777770
MOVEM 4,FNDEVT
MOVEI 1,0(3)
CAMN 1,KNIL
JRST FNDEV9
CAMN 1,KT
SKIPA 1,[0]
CALL IUNBOX
PUSHN 1
FNDEV9: HRRZ 1,2(VP)
CALL STKGP
JUMPE 1,STKER1
FNDEV5: GETPPI 2,1
MOVEI 3,0(PP)
CAMN 1,CF
JRST FNDEV1
GETPPO 3,1
FNDEV1: SUBI 3,0(2)
JUMPE 3,FNDEV2
HRLI 2,3
FNDEV3: HLRZ 4,@2
ANDI 4,777770
CAMN 4,FNDEVT
JRST FNDEV4
FNDEV7: SOJG 3,FNDEV3
FNDEV2: HRRZ 4,0(PP)
CAMN 4,KT
JRST FNDEV8 ;FLG T - RETURN N
GETCL 1,1
JUMPN 1,FNDEV5
CAMN 4,KNIL
JRST FNDEVD
POPN 1
FNDEVD: MOVEI 3,0 ;FOR INTERNAL CALLERS E.G. SETBLP
JRST FALSE ;NONE
FNDEV4: HRRZ 4,0(PP) ;FOUND ONE
CAMN 4,KT
JRST FNDEV6
CAMN 4,KNIL
JRST FNDEVC
SOSLE 0(CP) ;COUNT
JRST FNDEV7 ;NO ENUF
POPN 4 ;FLUSH NUM
FNDEVC: MOVEI 2,@2
HRRZ 3,0(2) ;RET PP PTR IN 2
EXCH 1,3 ;RET POS IN 3, FORM IN 1
RET
FNDEV6: AOS 0(CP) ;INCREM N
JRST FNDEV7
FNDEV8: POPN 1
JRST MKN
;BLIPSCAN(TYP IPOS) - FIND A FRAME CONTAINING A BLIP=TYP
BLPSCN: HRRZ 3,KNIL
CALL FNDEVL
JUMPE 3,FALSE ;NO SUCH
MOVEI 1,0(3)
JRST MKSTKP
;SETBLIP(TYP IPOS N VAL) - SET VALUE OF A BLIP
SETBLP: CALL FNDEVL
JUMPE 3,FALSE ;NOT FOUND
HRRZ 1,4(VP)
HRRM 1,0(2)
RET
U FNDEVT
;COPY STACK FROM A TO B (LINKS GO FROM B TO A)
;VALUE IS NEW B
CPYSTK: CALL STKGP
MOVEM 1,CPYA
MOVEM 1,CPYAA
HRRZ 1,2(VP)
CALL STKGP
INTOFF
PUSH CP,[R]
HRLM PP,0(CP) ;CLOSE OUT CURRENT FRAME
HRRZ 3,CF
SETCPO CP,3
HRRZM 3,CPYCF
MOVEM 1,CPYB
HRRZ 2,CPYA
GETCL 3,2
MOVEM 3,CPYCL
GETAL 3,2
MOVEM 3,CPYAL ;SAVE ORIG LINKS OF FIRST FRAME
JSP 7,REVLNK ;REVERSE LINKS
HRRZ 1,CPYA ;NOW LINKED FROM A TO B
SETZM CPYT
CPY3: MOVE 3,0(1)
HLRZ 2,3
MOVEI 3,1(3)
ADDI 2,0(3)
HLRE 5,PP
MOVN 5,5
JSYS PPCOP ;COPY BASIC FRAME - NEW IN 4
JRST PPFUL
EXCH 1,4
MOVEI 3,0(4)
JSP 7,ECOP ;COPY EXTENSION - NEW IN 3
GETNAR 2,3 ;ECOP INCREMS CXT OF ORIG
ADD 2,0(3) ;... MUST UNDO THAT
MOVSI 4,-1
ADDM 4,1(2)
SUBI 1,1
SETBAS 1,3 ;NEW BASIC FRAME POINTER
HRLM PP,0(CP) ;SET PPO AND CPO
SETCPO CP,3
SKIPE 2, CPYT
JRST CPY1
HRRZ 2,CPYCL ;FIRST ONE - INCREM USE(CLINK)
MOVSI 4,1
ADDM 4,USEWD(2)
CAMN 2,CPYAL ;ALINK=CLINK?
JRST CPY1
HRRZ 1,CPYAL ;NO - INCREM USE(ALINK) ALSO
ADDM 4,USEWD(1)
CPY1: GETCL 4,3
GETAL 5,3
SETCL 2,3 ;NEW CLINK
CAIN 4,0(5)
SETAL 2,3 ;NEW ALINK ALSO IF ORIGINALLY =
MOVEM 3,CPYT ;CURRENT BECOME S CLINK OF NEXT
HRRZ 2,CPYA
GETCL 1,2
HRRZM 1,CPYA
CAME 2,CPYB
JRST CPY3
HRRZ 1,CPYAA
HRRZ 2,CPYB
JSP 7,REVLNK ;RESTORE ORIG. LINKS
MOVEM CP,CF ;FLG NO CURRENT FRAME
HRRZ 1,CPYT ;...SO MKSTKP WONT BURP
HRROS USEWD(1) ;NEW STK PTR IS ONLY USE
CALL MKSTKP
INTON
HRRZ 3,CPYCF
JRST PPRCR ;GO RETURN FROM COPYSTK
U CPYCL
U CPYAL
U CPYAA
U CPYA
U CPYB
U CPYT
U CPYCF
;REVERSE STACK LINKS FROM B IN 1 TO A IN 2
REVLNK: MOVEI 5,0(1) ;ORIGINAL B
GETCL 3,1 ;CLINK(B)=X
REVL2: CAIN 1,0(2)
JRST REVL3
JUMPE 3,REVL3 ;BAD - NEVER GET TO A FROM B
GETCL 4,3 ;CLINK(X)=Y
SETCL 1,3 ;NEW CLINK(X) = B
GETAL 6,3
CAIN 6,0(4)
SETAL 1,3
MOVEI 1,0(3) ;B←X
MOVEI 3,0(4) ;X←Y
JRST REVL2
REVL3: GETCL 4,5
SETCL 3,5
GETAL 6,5
CAIN 4,0(6)
SETAL 3,5 ;SET BOTH LINKS IIF ORIGINALLY =
CAIN 1,0(2) ;RE-CHECK FOR ERROR
JRST 0(7)
MOVEI 2,0(5) ;RE-REVERSE FROM CURRENT TO ORIG
JSP 7,REVLNK
INTON
ERROR0 23,R
;BOX A STACK POINTER
MKSTK1: PUSH CP,1
MOVEI 1,STKPT
CALL GC1
POP CP,1
MKSTKP: CAMN 1,CF
JRST STKERR ;DONT BOX CF(HAVE TO COPY IT FIRST)
SKIPN 2,FRESTK
JRST MKSTK1 ;NO ROOM
INTOFF
MOVSI 3,1
ADDM 3,USEWD(1) ;INCREMENT USE
EXCH 1,0(2) ;STORE - GET NEW FREE
EXCH 1,FRESTK
INTON
RET
;MAKE A FRAME FOR FUNCTION FUNCTION
FUNCT1: STE 1,LIST
ERROR1 33,FUNCT1
PUSH CP,[0]
FUNCT2: STE 1,LIST
JRST FUNCT3
CDRA 2,1
CARA 1,1
PUSH PP,2
PUSH PP,1
CALL EVAL
POP PP,2
HRLI 1,0(2)
EXCH 1,0(PP)
AOS 0(CP)
JRST FUNCT2
FUNCT3: INTOFF
MOVEI 1,MKSTKP
EXCH 1,0(CP)
MOVEI 5,0(PP)
SUBI 5,0(1)
HRLM 5,0(CP)
MOVEI 3,1(CP)
EXCH 3,CF
MOVSI 4,1
ADDM 4,USEWD(3) ;INCREM USE OLD CF
SETCPO CP,3
PUSH CP,5
PUSH CP,3 ;ALINK = OLD CF
PUSH CP,[0] ;CLINK = 0
PUSH CP,HCRETC
HRLM 1,-3(CP) ;# ARGS
PUSH PP,KFNARG
HRLM PP,-2(CP) ;SET PPI
PUSH CP,[R]
HRLM PP,0(CP) ;SET PPO
HRLM CP,-1(CP) ;SET CPO
HRRZ 1,CF
MOVEI 4,-1
SETUSE 4,1 ;SET USE = -1, MKSTKP WILL INCREM
JRST PPRC31 ;GO RUN ORIGINAL FRAME
;ROUTINE TO DETERMINE TYPE OF ARGS FOR FUNCTION CALL
;CALLED WITH ATOM NAME IN AC1
;IF ATOM DOES NOT HAVE A LEGAL DEFINITION, RETURNS NO-SKIP
;OTHERWISE, RETURNS SKIP WITH BITS IN AC1, 34 AND 35
; 35=1 => NO-EVAL
; 34=1 => NO-SPREAD
ARGTYP: MOVE 2,1(1) ;GET DEFINITION
HLRZ 3,2 ;GET CALLING INSTRUCTION
LSH 3,-↑D9 ;RIGHT JUSTIFIED
CAIGE 3,HCCALV ;IS IT HCCAL
JRST .+3 ;NO
CAIG 3,HCCALV+3
JRST ARGT1 ;YES, FN IS SUBR
MOVEI 3,0(2) ;NO, GET DEFINITION POINTER
ARGTYB: CAMN 3,KNIL ;DEFINED?
RET ;NO, RETURN NO-SKIP
LDT 4,3 ;GET TYPE OF DEFINITION
CAIN 4,LISTT ;S-EXPRESSION?
JRST ARGT2 ;YES
CAIN 4,CCODET ;COMPILED CODE?
JRST ARGT3 ;YES
CAIE 4,HANDLT
RET ;ANYTHING ELSE IS ILLEGAL
LSHC 1,↑D13 ;SWAPPED, GET BITS FROM AC FIELD
JRST ARGT3A
ARGT1: MOVEI 1,0(3) ;FN IS SUBR, GET BITS FROM INSTR.
ARGT3A: ANDI 1,3
RSKP: AOS 0(CP) ;RETURN SKIPPING
RET
ARGT2: MOVEI 1,0 ;FN IS S-EXPRESSION
CARA 2,3
CAMN 2,KLAM ;LAMBDA?
JRST ARGT2A ;YES
CAME 2,KNLA ;NO, NLAMBDA?
JRST ARGT4
TRO 1,1 ;YES, MEANS NO-EVAL
ARGT2A: CDRA 3,3 ;GET VARIABLES
CARA 3,3
CAMN 3,KNIL
JRST RSKP
STE 3,LIST ;LIST?
TRO 1,2 ;NO, ATOM (ASSUMED) MEANS NO SPREAD
JRST RSKP ;RETURN AND SKIP
ARGT3: HRRZ 1,1(3) ;FN IS COMPILED, GET TYPE FROM 2ND WD
JRST ARGT3A
ARGT4: CAME 2,KFNARG ;FUNARG?
RET ;NO ILLEGAL
CDRA 3,3
CARA 3,3 ;GET THE FUNCTIONAL PART
STN 3,LIST
JRST ARGT2 ; LIST -
STE 3,ATOM
RET ;NOT ATOM 0R LIST - ILLEGAL
MOVEI 1,0(3)
JRST ARGTYP
ARGTY: STE 1,ATOM
JRST ARGTYA
CALL ARGTYP ;USER FUNCTION ARGTYPE
JRST FALSE
JRST MKN
ARGTYA: CALL SUBRP ;ARG NOT ATOM - ASSUME DEF
HRRZ 3,1(VP)
CAME 1,KNIL
JRST ARGTYC
LDT 2,3
CAIN 2,HANDLT
JRST ARGTYH
CALL ARGTYB
JRST FALSE
JRST MKN
ARGTYC: CARA 1,3
SUBI 1,ASZ
LSH 1,-4
ADDI 1,ASZ
RET
ARGTYH: JSYS SWPFIX ;GET THE DAMN THING INTO MEMORY
HRLI BR,(3) ;AND GET ARGTYPE BITS A LA
CALL SWAPIN ;TWO PAGES BELOW AT PUTD5
HRRZ 1,3(BR) ;HERE ARE THE BITS
SETZ BR,
JRST MKN
;GETD AND PUTD
GETD: STE 1,ATOM ;ATOM?
JRST FALSE ;NO - RET NIL
MOVE 2,1(1) ;GET DEF CELL
HLRZ 3,2 ;GET CALLING INSTRUCTION
LSH 3,-↑D9
CAIG 3,HCCALV+3 ;SUBR?
CAIGE 3,HCCALV
JRST GETD1 ;NO
LDB 1,[POINT 6,2,12] ;BITS - TYPE*16+#ARGS
ADDI 1,ASZ ;MAKE SMALL NUMBER
MOVEI 2,0(2) ;CODE ADDRESS
JRST CONS ;RETURN CONS OF TYPE INFO AND LOC
GETD1: MOVEI 1,0(2) ;NOT SUBR - RETURN POINTER
RET
PUTD: STE 1,ATOM
ERROR1 33,R
CAMN 2,KNIL
JRST PUTD2
LDT 3,2 ;GET TYPE OF DEF
CAIN 3,ATOMT ;ATOM?
JRST PUTDX ;YES, UNDEFINED
CAIN 3,HANDLT
JRST PUTD5
CAIE 3,CCODET ;COMPILED CODE?
JRST PUTD1 ;NO
HRLI 2,<PUSHJ CP,>B53 ;YES, INSERT CALLING INSTRUCTION
PUTD3: MOVEM 2,1(1) ;STORE IN FN CELL
PUTD4: MOVEI 1,0(2) ;RETURN DEF
RET
PUTD1: CAIE 3,LISTT ;LIST?
JRST PUTDX ;NO, UNDEFINED
CARA 3,2 ;YES
CAIG 3,ASZ+67
CAIGE 3,ASZ ;SUBR?
JRST PUTD2 ;NO, EXPR
SUBI 3,ASZ ;YES, GET ARG BITS
LSH 3,5
IORI 3,<HCCALV>B26 ;INSERT CALLING INSTRUCTION
HRLM 3,1(1)
CDRA 3,2 ;GET CODE LOC
CAMGE 3,ENDCOR ;CHECK FOR NON-DATA LOC
CAMG 3,BGNCOR
JRST .+2
JRST PUTD2 ;DATA, TREAT AS EXPR
HRRM 3,1(1)
JRST PUTD4
PUTD2: HLL 2,EVALUU ;USE EXCAL INSTRUCTION
JRST PUTD3
PUTD5: HRLI 2,<SBCAL 0,0>B53
JSYS SWPFIX
HRLZI BR,(2) ;LH(BR)=HANDLE FOR SWAPIN
CALL SWAPIN
HRRZ 3,3(BR) ;RH OF 1ST WD AFTER JSP TO ENTERF
DPB 3,[POINT 4,2,12] ;HAS THE BLOODY FNTYP BITS FOR SBCAL
SETZ BR,
JRST PUTD3
PUTDX: MOVEI 1,0(2) ;ERRONEOUS DEFINITION
ERROR1 33,R
;PREDICATES FOR FUNCTION TYPE, WORK GIVEN FN NAME OR DEF
CCODEP: LDT 2,1
CAIE 2,ATOMT ;ATOM?
JRST CCDP1 ;NO ASSUME GIVEN DEF
HRRZ 1,1(1) ;YES , GET DEF
LDT 2,1
CCDP1: CAIN 2,CCODET
JRST TRUE
JRST SCODP1
SUBRP: LDT 2,1
CAIE 2,ATOMT
JRST SUBRP1
HLRZ 1,1(1)
LSH 1,-↑D9
CAIG 1,HCCALV+3 ;HAND CODE CALL?
CAIGE 1,HCCALV
JRST FALSE
JRST TRUE
SUBRP1: CAIE 2,LISTT ;IS GETD A LIST?
JRST FALSE ;NO- FALSE
CARA 2,1
CAIG 2,ASZ+67 ;CAR BET. 0 AND 3 ?
CAIGE 2,ASZ
JRST FALSE ;NO - FALSE
CDRA 1,1
CAMGE 1,ENDCOR ;CDR NON-DATA ?
CAMGE 1,BGNCOR
JRST TRUE ;YES - IS SUBR
JRST FALSE
EXPRP: LDT 2,1
CAIE 2,ATOMT
JRST EXPRP1
MOVE 1,1(1)
XOR 1,EVALUU
TLNN 1,-1
CAMN 1,KNIL
JRST FALSE ;NOT EXPR, OR IS NIL
JRST TRUE
EXPRP1: CAIE 2,LISTT ;LIST?
JRST FALSE ;NO-FALSE
CALL SUBRP1
CAME 1,KNIL
JRST FALSE
JRST TRUE
SCODEP: LDT 2,1
CAIE 2,ATOMT
JRST SCODP1
HRRZ 1,1(1)
LDT 2,1
SCODP1: CAIN 2,HANDLT
JRST TRUE
JRST FALSE
;BASIC PREDICATES
ATOM: LDT TP,1
CAIL TP,ATOMT ;ATOM IS REALLY ATOM OR NUMBER
CAILE TP,SMALLT
JRST FALSE
JRST TRUE
LITATM: STE 1,ATOM
JRST FALSE
JRST TRUE
EQ: CAIE 1,0(2) ;LIKE COMPILED EQ
JRST FALSE
JRST TRUE
NULL: CAME 1,KNIL ;ALSO NOT
JRST FALSE
JRST TRUE
NUMBRP: LDT TP,1
CAIL TP,FLOATT ;FIXED, FLOATING, OR SMALL
CAILE TP,SMALLT
JRST FALSE
RET
LISTP: STE 1,LIST
JRST FALSE
RET
FLOATP: STE 1,FLOAT
JRST FALSE
RET
MINUSP: CALL GUNBOX
JUMPL 1,TRUE
JRST FALSE
STRNGP: STE 1,STPT
JRST FALSE
RET
HANDLP: STE 1,HANDL
JRST FALSE
RET
STKPP: STE 1,STKP
JRST FALSE
RET
AND: MOVE 2,KT
AND1: CAMN 1,KNIL ;MORE CLAUSES?
JRST R2 ;NO, RETURN LAST VALUE
HRLI 1,PRBLIP
PUSH PP,1
CARA 1,1 ;NEXT CLAUSE
CALL EVAL
MOVEI 2,0(1)
POP PP,1
CAMN 2,KNIL ;NIL?
JRST FALSE ;YES, FAIL => RETURN NIL
CDRA 1,1 ;NO, CONTINUE
JRST AND1
OR:
OR1: CAMN 1,KNIL ;MORE CLAUSES
RET ;NO, FAIL
HRLI 1,PRBLIP
PUSH PP,1
CARA 1,1 ;NEXT CLAUSE
CALL EVAL
MOVEI 2,0(1)
POP PP,1
CAME 2,KNIL ;NIL?
JRST R2 ;NO, RETURN IT
CDRA 1,1 ;YES, CONTINUE
JRST OR1
IEQP: CALL I2UBOX
CAME 1,2
JRST FALSE
JRST TRUE
EQP: CAIN 1,0(2) ;EQ WHICH WORKS FOR NUMBERS TOO
JRST TRUE ;...AND STACK POINTERS
MOVEI 6,0(2)
CALL GUBS
EXCH 1,6 ;SAVE UNBOXED NUMBER
MOVEI 7,0(2) ;AND ITS TYPE
CALL GUBS ;UNBOX SECOND ARG
CAIN 2,0(7) ;BOTH SAME TYPE?
JRST EQPCV ;YES- COMPARE VALUES
CAIE 7,FLOATT ;NO- IS ONE ARG FLOATING?
JRST EQP1 ;CHECK OTHER ARG
EQP2: CALL FXFLT ;CONVERT FIXED TO FLOATING
JUMPN 2,FALSE ;IF SOMETHING LOST IN CONVERSION, FALSE
EQPCV: CAME 6,1
JRST FALSE
JRST TRUE
EQP1: CAIE 2,FLOATT
JRST EQPCV ;NEITHER ARG IS FLOATING
EXCH 1,6 ;GET FIXED ARG TO 1
JRST EQP2
GUBS: LDT 2,1
CAIN 2,SMALLT
JRST IUBS
CAIE 2,FLOATT
CAIN 2,FIXT
JRST IUB2 ;FIXED OR FLOAT, GET VALUE
CAIN 2,STKPT
JRST IUB2 ;STACK POINTER - GET VALUE
SUB CP,BHC+1 ;NOT NUMBER, FLUSH EXTRA RETURN
JRST FALSE ;AND RETURN FALSE
;BASIC SUBR'S
SET: PUSH PP,2 ;VALUE
JRST SET1
SETQ: CDRA 1,1 ;GET EXPR
CARA 1,1
CALL EVAL
PUSH PP,1
HRRZ 1,1(VP)
CARA 1,1 ;GET NAME
SET1: STE 1,ATOM ;ATOM?
ERROR1 16,R ;NO, ERROR
CAMN 1,KNIL ;NAME IS NIL?
JRST SETERR ;YES, ILLEGAL TO SET NIL
CALL PPLOOK ;FIND LOCATION
JFCL 0 ;VALUE CELL
POP PP,2
HRRM 2,0(1)
R2: MOVEI 1,0(2)
RET
SETERR: HRRZ 1,1(VP)
ERROR1 6,R
SETN: STE 1,ATOM
ERROR1 16,R ;NON ATOMIC ARG
CALL PPLOOK
JFCL
PUSH PP,1 ;SAVE BINDING LOC (OK. IS BAS. FR.)
HRRZ 1,2(VP)
CALL EVAL
CALL GUNBOX
PSETN @0(PP)
SUB PP,BHC+1
RET
;CONTROL SUBR'S
DDTC: HALTF
RET
OFFINT: CLRICH
RET
LOGOUT: CALL OFFINT
HALTF
LOGRE: SETICH
JRST FALSE
CONSCF: CAME 1,KNIL
JRST CONSCN
MOVE 1,CNSCNT
JRST MKN
CONSCN: CALL IUNBOX
MOVEM 1,CNSCNT
HRRZ 1,1(VP)
RET
;BOXCOUNT(TYPE NEWCOUNT)
BOXCNT: CAME 2,KNIL ;JUST GET CURRENT COUNT?
JRST BOXCN1 ;NO
HRRZ 2,1(VP) ;YES - GET TYPE
MOVE 1,IBOXCN ;GET PROPER COUNTER
CAME 2,KNIL
MOVE 1,FBOXCN
CAIGE 1,MSN/2 ;DON'T COUNT THE BOXING OPERATION
CAMG 1,[-MSN/2]
SOS IBOXCN
JRST MKN
BOXCN1: MOVEI 1,0(2) ;GET THE NEW COUNT
CALL IUNBOX
HRRZ 2,1(VP) ;GET TYPE
MOVEI 3,IBOXCN ;GET THE PROPER COUNTER
CAME 2,KNIL
MOVEI 3,FBOXCN
MOVEM 1,0(3)
HRRZ 1,2(VP) ;RETURN THE NEW COUNT
RET
;RECLAIM AND MINFS
RECLM: CAMN 1,KNIL
SKIPA 1,[LISTT]
CALL IUNBOX
ANDI 1,MTYPN ;ARG IS TYPE
SKIPN TYPBLK(1)
JRST FALSE ;NO SUCH TYPE
PUSH CP,1
PUSH CP,[RECLM1]
CAIN 1,ARRAYT
JRST ARRGC
CAIN 1,STRNGT
JRST STRGC
JRST GC1
RECLM1: POP CP,1
HRRZ 1,TYPBLK(1)
MOVE 1,TNFR(1)
JRST MKN
MINFS: MOVEI 1,0(2)
CAMN 1,KNIL ;SECOND ARG NIL MEANS LIST
SKIPA 1,[LISTT]
CALL IUNBOX ;ELSE TYPE NUMBER
ANDI 1,MTYPN
HRRZ 2,TYPBLK(1)
JUMPE 2,FALSE
PUSHN 2
HRRZ 1,1(VP)
CAMN 1,KNIL
SKIPA 1,TMIN(2)
CALL IUNBOX
POPN 2
EXCH 1,TMIN(2)
JRST MKN
;OPENR/CLOSER
OPENR: CALL IUNBOX
MOVE 1,0(1)
JRST MKN
CLOSER: CALL IUNBOX ;ADDRESS
PUSHN 1
HRRZ 1,2(VP)
CALL GUNBOX ;CONTENTS
POPN 7
MOVEM 1,0(7)
HRRZ 1,2(VP)
RET
;MAP INDEF NUMBER OF ARGS
;COUNT OF ARGS SUPPLIED IN AC1
;INSTRUCTION TO EXECUTE TO PROCESS EACH ARG FOLLOWS CALL
MPARG: MOVN 7,1
JUMPGE 7,RSKP ;NO ARGS
HRLI 7,-1(7)
HRRI 7,0(VP)
JRST MPARG1
PLUS1: PUSHN 7
HRRZ 1,0(7) ;GET ARG
XCT @-2(CP) ;CALL EXECUTION FUNCTION
POPN 7
MPARG1: AOBJN 7,PLUS1
JRST RSKP
;NTYP - GET TYPE OF ARG
NTYP: LDT 1,1
JRST MKN
;NCONC
NCONC: MOVE 5,KNIL
CALL MPARG
CALL NCONC3
MOVE 1,5
RET
NCONC3: STE 5,LIST
JRST NCONC1
SKIPA
NCONC2: MOVEI 4,0(3)
CDRA 3,4
STN 3,LIST
JRST NCONC2
HRLM 1,0(4)
RET
NCONC1: MOVEI 5,0(1)
MOVEI 4,0(1)
RET
;FMEMB
FMEMB: HRRZ 3,0(2)
CAMN 3,1
JRST FMEMBE
HLRZ 2,0(2)
CAME 2,KNIL
JRST FMEMB
FMEMBE: MOVEI 1,0(2)
RET
;MAKE HANDLE
MKHDL1: PUSHN 1
MOVEI 1,HANDLT
CALL GC1
POPN 1
MKHDL: SKIPN 2,FREHDL
JRST MKHDL1 ;NO SPACE
EXCH 1,0(2)
EXCH 1,FREHDL
RET
UMKHDL: CALL IUNBOX
JRST MKHDL
;INTEGER ARITHMETIC FUNCTIONS
MINUS: CALL GUNBOX
MOVN 1,1
JRST GBOX
;IPLUS
IPLUS: PUSHN [0] ;INITIAL SUM
CALL MPARG ;MAP ALL ARGS
CALL PLUS2 ;WITH PLUS2
ITMS1: POPN 1 ;ACCUMULATED VALUE
JRST MKN
PLUS2: CALL IUNBOX
ADDM 1,-4(CP) ;STACK HAS FLG,INIT,RET,FLG,TEM
RET
ITIMES: PUSHN [1] ;INITIAL PRODUCT
CALL MPARG
CALL ITMS2
JRST ITMS1
ITMS2: CALL IUNBOX
IMULM 1,-4(CP)
RET
LOGOR: PUSHN [0]
CALL MPARG
CALL LOGOR1
JRST ITMS1
LOGOR1: CALL IUNBOX
IORM 1,-4(CP)
RET
LOGAND: PUSHN [-1]
CALL MPARG
CALL LOGAN1
JRST ITMS1
LOGAN1: CALL IUNBOX
ANDM 1,-4(CP)
RET
LOGXOR: PUSHN [0]
CALL MPARG
CALL LOGXR1
JRST ITMS1
LOGXR1: CALL IUNBOX
XORM 1,-4(CP)
RET
LSHFT: CALL I2UBOX ;LOGICAL SHIFT
LSH 1,0(2)
JRST MKN
ASHFT: CALL I2UBOX ;ARITHMETIC SHIFT
ASH 1,0(2)
JRST MKN
;GENERAL PLUS
PLUS: CALL HIGHT
JRST IPLUS
FPLUS: PUSHN [0] ;FLOATING PLUS
CALL MPARG
CALL FPLUS2
FPLUS1: POPN 1
JRST MKFN
FPLUS2: CALL FUNBOX
FADM 1,-4(CP)
RET
;UNBOX NUMBER TO FLOATING
FUNBOX: CALL GUNBOX ;UNBOX NUMBER
CAIN 2,FLOATT ;FLOATING?
RET ;YES- RETURN
FXFLT: IDIVI 1,400 ;FIXED TO FLOAT CONVERSION
FSC 1,243
FSC 2,233
FADL 1,2 ;LEAVE LOST PART IF ANY IN 2
RET
;FIND MOST COMPLICATED TYPE IN ARG LIST, SKIP IF FLOATING
HIGHT: PUSH CP,1 ;SAVE NUMBER OF ARGS
MOVEI 5,SMALLT
CALL MPARG
CALL HGH1
CAIN 5,FLOATT
AOS -1(CP)
POP CP,1
RET
HGH1: LDT 2,1
CAIGE 2,0(5)
MOVEI 5,0(2) ;LOW TYPE NUMS ARE MOST COMPLEX
RET
;GENERAL TIMES
TIMES: CALL HIGHT
JRST ITIMES
;FLOATING TIMES
FTIMES: MOVSI 5,201400 ;1.0
PUSHN 5
CALL MPARG
CALL FTIME2
JRST FPLUS1
FTIME2: CALL FUNBOX
FMPRM 1,-4(CP)
RET
;UNBOX NUMBERS IN 1 AND 2 TO HIGHEST TYPE, RESULTS IN 1 AND 2
;SKIP IF FLOATING
G2UBOX: LDT 4,2
LDT 3,1
CAIE 4,FLOATT
CAIN 3,FLOATT
JRST U2B1 ;AT LEAST ONE IS FLOATING
I2UBOX: PUSH PP,2 ;UNBOX 1 AND 2 TO INTEGER
CALL IUNBOX
POP PP,2
PUSHN 1
MOVE 1,2
CALL IUNBOX
U2B2: MOVE 2,1
POPN 1
RET
U2B1: AOS 0(CP)
F2UBOX: PUSH PP,2 ;UNBOX 1 AND 2 TO FLOATING
CALL FUNBOX
POP PP,2
PUSHN 1
MOVE 1,2
CALL FUNBOX
JRST U2B2
;CONVERT NUMBER IN 1 TYPE IN 2, TO TYPE IN 3
CNVNUM: CAIN 3,SMALLT
MOVEI 3,FIXT
CAIN 2,SMALLT
MOVEI 2,FIXT
CAIN 3,0(2)
RET
CAIE 3,FLOATT
JRST FLTFX
JRST FXFLT ;FIXED TO FLOAT
;GREATERP- GENERAL
GRTRP: CALL G2UBOX
JFCL 0
GRTR1: CAMG 1,2
JRST FALSE
JRST TRUE
;GREATERP- INTEGER
IGRTRP: CALL I2UBOX
JRST GRTR1
;GREATERP - FLOATING
FGTP: CALL F2UBOX
JRST GRTR1
;QUOTIENT- GENERAL
QTENT: CALL G2UBOX
JRST IQT1
JRST FQT1
;REMAINDER- GENERAL
RMNDR: CALL G2UBOX
JRST IRMND1
JRST FRMND1
;INTEGER QUOTIENT
IQTENT: CALL I2UBOX
IQT1: IDIV 1,2
JRST MKN
;INTEGER REMAINDER
IRMNDR: CALL I2UBOX
IRMND1: IDIV 1,2
MOVE 1,2
JRST MKN
;FLOATING QUOTIENT
FQTENT: CALL F2UBOX
FQT1: FDV 1,2
JRST MKFN
;FLOATING REMAINDER
FRMNDR: CALL F2UBOX
FRMND1: MOVE 3,2
MOVEI 2,0
FDVL 1,3
MOVE 1,2
FSC 1,0 ;NORMALIZE
JRST MKFN
;PROGN (EVAL LIST OF FORMS)
PROGN: MOVE 2,1
PROGN1: STE 2,LIST ;END OF LIST?
RET ;YES
CARA 1,2 ;NO, GET NEXT FORM
HRLI 2,PRBLIP
PUSH PP,2 ;SAVE REMAINDER OF LIST
CALL EVAL
POP PP,2
CDRA 2,2 ;GET REST OF LIST
JRST PROGN1
;VERY BASIC SUBR'S
CAR: CARA 1,1
RET
CDR: CDRA 1,1
RET
RPLACA: CAMN 1,KNIL
JRST RPLNIL
HRRM 2,0(1)
RET
RPLACD: CAMN 1,KNIL
JRST RPLNIL
HRLM 2,0(1)
RET
RPLNIL: CAMN 2,KNIL ;RPLAC(A-D) NIL NOT PERMITTED
RET ;EXCEPT WITH NIL
MOVEI 1,0(2)
ERROR1 7,R
;PROG1 (EVAL A LIST OF FORMS AND RETURN THE FIRST ONE)
PROG1: CAMN 1,KNIL ;EMPTY LIST?
RET ;YES
MOVEI 2,0(1) ;NO, GET FIRST FORM
CARA 1,2
CDRA 2,2
PUSH PP,2 ;SAVE REST OF LIST
CALL EVAL ;EVAL FIRST FORM
EXCH 1,(PP) ;GET REST OF LIST AND SAVE FIRST RESULT
CALL PROGN ;EVAL REST OF LIST
POP PP,1 ;RETURN THE FIRST ITEM
RET
;COND
COND:
COND2: STE 1,LIST ;END OF CLAUSES?
RET ;YES, RETURN NIL
HRLI 1,PRBLIP
PUSH PP,1 ;SAVE LIST
CARA 1,1 ;GET PREDICATE
STE 1,LIST ;MAKE SURE CLAUSE LOOKS GOOD
RET
CARA 1,1
CALL EVAL
POP PP,2
CAMN 1,KNIL ;TEST
JRST COND1 ;FAILS, GET NEXT CLAUSE
CARA 2,2 ;GET REMAINDER OF CLAUSE
CDRA 2,2
JRST PROGN1 ;GO EVAL CONSEQUENCES
COND1: CDRA 1,2 ;GET NEXT CLAUSE
JRST COND2
;PROG, GO, RETURN
PROG: CARA 1,1 ;GET VARIABLE LIST
PRO1: STE 1,LIST ;ANY VARIABLES LEFT?
JRST PRO11
CARA 3,1 ;GET A VARIABLE
STE 3,LIST ;LIST?
JRST PRO14 ;NO- DO SIMPLE CASE
HRLZ 4,0(3) ;YES - CAR TO LEFT
PUSH PP,4 ;SAVE NAME
PUSH PP,1 ;SAVE CURRENT VARIABLE LIST
CDRA 3,3 ;GET VALUE
CARA 1,3
CALL EVAL ;EVAL IT
HRRM 1,-1(PP) ;SAVE VALUE WITH NAME
POP PP,1 ;GET BACK VARIABLE LIST
PRO15: CDRA 1,1
JRST PRO1
PRO14: HRLI 3,0(3) ;SIMPLE CASE - NAME
HRR 3,KNIL ;VALUE NIL
PUSH PP,3
JRST PRO15
PRO11: HRRZ 3,CF ;ARGS ALL DONE - FUDGE FRAME
GETPPI 2,3 ;BEG TEMS -1
MOVEI 1,0(PP)
SUBI 1,0(2) ;# ARGS
MOVEI 2,PROGC-1 ;FAKE FN NAME
PUSHJ CP,EFNCAL
POPJ CP,
PROGC: PUSHJ CP,.+1
HRLM 1,-3(CP)
PUSH PP,KPRGLM ;FAKE FN NAME
HRLM PP,-2(CP)
HRRZ VP,-3(CP)
PRO12: HRRZ 2,CF
GETCL 2,2 ;PRIOR FRAME
GETBAS 2,2
HRRZ 2,1(2) ;CONTAINS WHOLE PROG
PRO3: CDRA 2,2
CAMN 2,KNIL
JRST R2 ;DONE - RETURN NIL
HRLI 2,PRBLIP
PUSH PP,2 ;CURRENT STATE OF PROG
CARA 1,2 ;GET A STATEMENT
STE 1,ATOM ;LABEL?
CALL EVAL ;NO - EVAL IT
POP PP,2 ;GET BACK PROG
JRST PRO3
GO: CARA 1,1 ;GET GO LABEL
MOVEM 1,PROT1 ;SAVE IT
HRRZ 3,CF ;GET CURRENT FRAME
CALL FPROG ;FIND FIRST PROG
JRST PROGER ;NOPE
GO2: INTOFF
JSP 7,UNSTK ;FLUSH TO IT
HRRZM 1,CF ;THE PROG FRAME
GETCPO 4,1
HLRZ 2,0(4)
JSYS RECP
MOVEI 4,0(2)
JSYS REPP
INTON
GETCL 2,1 ;PRIOR FRAME
GETBAS 2,2 ;...FIRST ARG
HRRZ 2,1(2) ;...IS WHOLE PROG
HRRZ 1,PROT1 ;THE LABEL
GO1: CDRA 2,2
CAMN 2,KNIL ;ANY STATEMENTS LEFT?
JRST GO3 ;NO, UNDEFINED LABEL
CARA 3,2
CAIN 3,0(1) ;IS THIS DESIRED LABEL?
JRST GOR ;YES, CONTINUE WITH PROG
JRST GO1 ;NO, CONTINUE SEARCH
GO3: HRRZ 3,CF ;TRY HIGHER PROG
GETCL 3,3
CALL FPROG
JRST PROGER ;NOPE
GETCL 2,1
GETBAS 2,2
HRRZ 2,1(2) ;THIS WHOL PROG
PUSH PP,1 ;SAVE THIS FRAME
HRRZ 1,CF
GETCL 1,1
GETBAS 1,1
HRRZ 1,1(1) ;PRIOR PROG
;*** CALL MM ;WAS IT INNER?
;*** CAMN 1,KNIL
;*** JRST PROGE1
POP PP,1 ;YES
JRST GO2
PROGE1: POP PP,1
PROGER: HRRZ 1,PROT1
ERROR1 10,RESET
U PROT1
GOR: MOVEI 1,0(2) ;PROG AT LABEL
HRRZ 3,CF
GETUSE 4,3 ;SEE IF USE(PROG)>0
SOJL 4,GOR1
SETUSE 4,3 ;YES - DECR.
JSP 7,ECOP ;COPY PROG FRAME - SO CAN FUDGE IT
GOR1: MOVEI CP,FLGWD+1(3) ;FLUSH C-TEMS BACK TO FLG+1
HRLI CP,@ICPC
SETCPO CP,3 ;AND SET CPO TO SHOW IT
GETPPI PP,3 ;NOW FLUSH P-TEMS
HRLI PP,@IPPC
MOVEI 2,0(PP)
HRLI 2,PRORR
MOVSM 2,FLGWD+1(3) ;FIX REAL RET. AND PPO
JRST PPRCR ;AND GO RUN THE PROG
PRORR: MOVEI 2,0(1) ;GET HERE
JRST PRO3
RETURN: HRRZ 3,CF
CALL FPROG ;FIND A PROG
RETU3: ERROR1 3,RESET ;NONE
HRRZ 2,1(VP) ;THE VALUE
RETU2: INTOFF
RETU4: JSP 7,UNSTK ;FLUSH TO PROG OR FRAME IN 1
EXCH 1,2 ;SWITCH FRAME AND VALUE
GETCPO 4,2 ;END PROG FRAME
HLRZ 3,0(4) ;PPO OF PROG FRAME
JSYS RECP ;SET UP CP TO CPO
MOVEI 4,0(3)
JSYS REPP ;SET UP PP AT PPO
MOVEI 3,0(2) ;PROG FRAME
HRRZM 3,CF ;RESET CF - UNSTK KILLS IT
GETUSE 4,3
SOJL 4,RETU1 ;USE(PROG)>0?
SETUSE 4,3 ;YES -DECR.
JSP 7,ECOP ;AND COPY IT CAUSE ABOUT TO FLUSH IT
RETU1: MOVEI CP,FLGWD(3) ;DELETE C-TEMS
HRRZ 2,FLGWD+2(3) ;SWAP FRAME?
CAIN 2,SWPRET
ADDI CP,2 ;YES - RETURN THROUGH SWPRET
HRLI CP,@ICPC
INTON
GETCL 2,3
JUMPE 2,RETU3 ;ILLEGAL RETFROM (PAST TOP)
POPJ CP, ;RETURN FROM PROG
;FIND A PROG, 3 HAS ATARTING FRAME - RET FOUND FR. IN 1
;SKIP IF FOUND
FPROG: MOVE 1,KPRGLM
MOVNI 2,1
CALL STKPOS
SKIPE 1
AOS 0(CP)
RET
;FOR INTERNAL USE - RELEASE STACK BACK TO POS(UNBOXED)
;1 HAS PLACE TO RELEASE TO(PRESERVED), 2 HAS RANDOM VALUE TO SAVE
;CALLED WITH JSP 7,
;NOTE THAT THERE IS A BUG HERE IF THE FIRST PUSH CAUSES CF
;TO MOVE AND C(1) OR C(2) ARE CF -- I THINK THIS WONT
;HAPPEN BECAUSE NEVER CALLED WITHOUT PRIOR PUSHJ IN
;SAME FRAME GUARANTEEING SPACE FOR AT LEAST ONE PUSH
;TERMINAL INTERRUPTS SHOULD BE OFF
UNSTK: PUSH CP,[XWD 0,R] ;CLOSE OUT CURRENT FRAME
JSYS SWPFIX
HRRZ 4,CF
HRLM PP,0(CP) ;SET PPO
SETCPO CP,4 ;AND CPO
MOVSI 3,1
ADDM 3,USEWD(1) ;INCREM. USE(1) SO WILL STAY
MOVEM CP,CF ;FLG NO VALID FRAME
MOVEM PP,OPP ;IN CAS STACK OVERFLOW
PUSH PP,2 ;SAVE RANDOM VALUE
MOVEI 2,0(4) ;FROM CURRENT
CALL FLFR ;FLUSH(MAY OR MAY NOT DECR. USE)
POP PP,2 ;RESTORE RANDOM VALUE
JRST 0(7)
MM: CAIN 1,0(2)
POPJ CP,
STE 2,LIST
JRST FALSE
PUSH PP,2
HRLM 1,0(PP)
CARA 2,2
CALL MM
POP PP,2
CAME 1,KNIL
RET
HLRZ 1,2
CDRA 2,2
JRST MM
;FOR COMPILED PROG RETURNS OUT OF OPEN LAMBDAS
NLRET: PUSH PP,1
MOVE 1,2
HRRZ 2,CF
CALL STKNTH
POP PP,2
JRST RETU2
;FOR COMPILED PROG - NON-LOCAL GO'S
;MOVEI 2,# PTEMS TO SAVE MOVNI 1,N PUSHJ CP,NLGO
NLGO: HRLM 2,0(CP)
HRRZ 2,CF
CALL STKNTH
POP CP,2
INTOFF
JSP 7,UNSTK
HRRZM 1,CF
EXCH 1,2
GETCPO 4,2
HLRZ 3,0(4)
JSYS RECP
MOVEI 4,0(3)
JSYS REPP
MOVEI 3,0(2)
GETUSE 4,3
SOJL 4,NLGO1
SETUSE 4,3
JSP 7,ECOP
NLGO1: HRRZ 2,FLGWD+2(3)
CAIE 2,SWPRET ;SWAPPED FRAME?
JRST NLGO2
HRRZ 2,0(CP) ;YES
CAIE 2,BRREST ;GOTTA RESTORE?
JRST NLGO3 ;NOPE (SUSPECT ALWAYS HAVE TO)
HRLM 1,FLGWD+2(3) ;REPLACE REAL RETURN
HRRI 1,BRREST ;GO TO BRREST FIRST
NLGO3: MOVEI CP,FLGWD+2(3)
SKIPA
NLGO2: MOVEI CP,FLGWD(3) ;DELETE C-TEMS
HRLI CP,@ICPC
GETPPI PP,3
HLRZ 2,1 ;# PTEMS TO SAVE
ADDI PP,0(2)
HRLI PP,@IPPC
INTON
HRRZ VP,0(3)
JRST 0(1)
;SET FREBRK
GCTRP: CAMN 1,KNIL
JRST GCTR1 ;ARG NIL - RET FREE COUNT
CALL IUNBOX
EXCH 1,FREBRK
JRST MKN
GCTR1: MOVE 1,FRECNT
JRST MKN
;SET FLAG FOR GC MESSAGES
GCGAG: MOVE 2,KNIL
LDT 3,1
CAIE 3,LISTT ;IS THE ARG A LIST?
JRST GCGAG1 ;YES
CDRA 2,1 ;NO - SPLIT INTO 2 ARGS
CARA 1,1
GCGAG1: CAMN 1,KNIL
SETZ 1,
EXCH 1,GCMESF
SKIPN 1
MOVE 1,KNIL
CAMN 2,KNIL
SETZ 2,
EXCH 2,GCMES2
JUMPN 2,CONS ;HAVE A SECOND PART - CONS RESULT
RET
; SET FLAG FOR HERALD
HERALD: CAMN 1,KNIL
SETZ 1,
EXCH 1,HLDMSG
JUMPE 1,FALSE
RET
;MAP ON ALL ATOMS
MPATMS: HRRZ 1,NHP ;# HASH TABLE PAGES
MOVEM 1,ATMTT
MAPA3: HRRZ 3,ATOMHT(1)
MOVEI 4,MPS
HRLI 3,4 ;ATOMHT(4)
MAPA2: MOVE 1,@3
TLNN 1,777776
JRST MAPA1
MOVEI 1,-2(1)
PUSHN 3
PUSHN 4
PUSH PP,1(VP) ;FN
PUSH PP,1
LCALL KAPP.,2
POPN 4
POPN 3
MAPA1: SOJGE 4,MAPA2
SOSLE 1,ATMTT
JRST MAPA3
JRST FALSE
;MAKE INTEGER NUMBER
MKN: CAIGE 1,MSN/2 ;TEST FOR SMALL NUMBER
CAMG 1,[-MSN/2]
JRST MKN1
ADDI 1,ASZ ;SMALL NUMBER 0
RET
MKN1: SKIPN 2,FREENM ;TEST FREE LIST
JRST MKN2 ;EMPTY
EXCH 1,0(2) ;NOT EMPTY, STORE NUMBER AND GET
EXCH 1,FREENM ;UPDATE FREE LIST
AOS IBOXCN ;UPDATE INTEGER BOX COUNT
RET
MKN2: PUSHN 1 ;SAVE NUMBER
CALL INTGC ;INITIATE GARBAGE COLLECTION
POPN 1
JRST MKN1 ;TRY AGAIN
;UNBOX NUMBER TO INTEGER
IUNBOX: CALL GUNBOX ;UNBOX NUMBER
CAIE 2,FLOATT ;FLOATING?
RET ;NO- RETURN
FLTFX: MULI 1,400 ;CONVERT FLOAT TO FIXED
TSC 1,1
EXCH 1,2
JUMPL 1,FLTFX1
ASH 1,-243(2)
RET
FLTFX1: MOVN 1,1
ASH 1,-243(2)
MOVN 1,1
RET
TRUE: MOVE 1,KT ;RETURN T
RET
FALSE: MOVE 1,KNIL ;RETURN NIL
RET
;GENERAL UNBOX- GET VALUE IN 1, TYPE IN 2
GUBEE: POP CP,FF ;AFTER ERROR
GUNBOX: LDT 2,1 ;GET TYPE TO 2
CAIN 2,SMALLT ;SMALL?
JRST IUBS
CAIL 2,FLOATT ;FLOATING OR FIXED?
CAILE 2,FIXT
JRST GUBE ;NO - ERROR
IUB2: MOVE 1,0(1) ;YES- GET VALUE
RET
IUBS: SUBI 1,ASZ ;SMALL NUMBER ZERO
RET
GUBE: PUSH CP,FF ;PRESERVE FF FOR COMPILED CODE
ERROR1 12,GUBEE
;GENERAL BOX- GIVEN VALUE IN 1, TYPE IN 2, DO APPROPRIATE BOX
GBOX: CAIE 2,FLOATT
JRST MKN ;INTEGER
MKFN: SKIPN 2,FREEFL ;MAKE FLOATING NUMBER
JRST MKF1 ;NO SPACE
EXCH 1,0(2) ;STORE NUMBER
EXCH 1,FREEFL ;GET POINTER, UPDATE FREE
AOS FBOXCN ;UPDATE FLOATING BOX COUNT
RET
MKF1: PUSHN 1
MOVEI 1,FLOATT
CALL GC1
POPN 1
JRST MKFN
;ALLOCATE AN ELEMENT OF A USER DATA TYPE
;TYPE NUMBER IN AC
NALLOC: CAIL 1,MSYST+1+ASZ ;CHECK DATA TYPE NUMBER
CAIL 1,MTYPN+ASZ
ERROR1 41,NALLOC
MOVEI 4,-ASZ(1) ;SAVE TYPE NUMBER
ANDI 4,77
NALOC2: SKIPN 2,TYPBLK(4) ;GET TYPE ENTRY
ERROR1 41,NALLOC
SKIPN 1,TFRE(2) ;FREE LIST EMPTY?
JRST GCUSER ;YES
HRRZ 3,(1) ;GET ADDR OF NEXT POINT
MOVEM 3,TFRE(2) ;AND STORE IT
HLRZ 2,TSIZ(2) ;CLEAR THE ITEM!
SETZM 0(1) ;CLEAR FIRST WORD
CAIN 2,1 ;ONLY 1 WORD?
JRST NALOC1 ;YES
HRLI 3,0(1) ;SET UP BLT WORD
HRRI 3,1(1)
ADDI 2,-1(1) ;STOPPING ADDRESS
BLT 3,0(2) ;CLEAR THE REST OF THE ITEM
NALOC1: RET
GCUSER: MOVEI 1,0(4)
CALL GC1 ;RECLAIM
JRST NALOC2
;DEFINE A USER DATA TYPE
;NWRDS IN 1
;NPTRS IN 2
DEFTYP: CALL IUNBOX ;UNBOX ARGS
PUSHN 1
HRRZ 1,2(VP)
CALL IUNBOX
MOVE 2,1
POPN 3
SETZM 1,DEFNUM
MOVSI 1,377777
MOVEM 1,DEFDIF
SKIPLE 3 ;NPTRS GR 0?
SKIPGE 2 ;YES, NWORDS NEGATIVE?
ERROR0 33,DEFTYP ;YES
LSH 3,1
CAILE 2,0(3) ;WILL PTRS FIT IN NWRDS?
ERROR0 33,DEFTYP ;NO
LSH 3,-1
MOVE 1,[XWD MSYST-MTYPN+1,MSYST+1]
DEFTP3: SKIPN 4,TYPBLK(1) ;EMPTY?
JRST DEFTP2 ;YES - USE IT!
HLRZ 5,TYPSIZ(1) ;GET STATUS AND NUM OF PTRS.
CAIN 5,1 ;STILL IN USE?
JRST DEFTP4 ;YES
HRRZ 5,TYPSIZ(1)
CAIE 2,0(5) ;STILL EQUIVALENT?
JRST DEFTP4 ;NO
HLRZ 5,TSIZ(4) ;GET NUMBER OF WORDS
CAILE 3,0(5) ;FIT AS A SUBSET?
JRST DEFTP4 ;NO
CAML 3,DEFDIF ;BETTER FIT THAN BEFORE
JRST DEFTP4 ;NO
MOVEM 3,DEFDIF ;YES
HRRZM 1,DEFNUM
DEFTP4: AOBJN 1,DEFTP3 ;TRY AGAIN
SKIPN 1,DEFNUM ;NONE FREE - ANY RECLAIMED?
ERROR0 42,NALLOC1 ;NO - ERROR OUT
HRRZ 2,TYPSIZ(1) ;SET STATUS FLAG
HRLI 2,1
MOVEM 2,TYPSIZ(1)
JRST MKN
DEFTP2: MOVEI 1,0(1)
PUSHN 1 ;SAVE TYPE NUMBER
HRLM 3,TUSER ;SO GC KNOWS SIZE
HRLI 2,1 ;SET STATUS
MOVEM 2,TYPSIZ(1) ;SAVE SIZE INFO.
MOVEI 2,(1) ;SET UP TO CALL GCTBS
MOVEI 10,TUSER
IMULI 1,NTWN
MOVEI 7,USEBLK-<<MSYST+1>*NTWN>(1)
MOVEM 7,TYPBLK(2)
PUSHJ GP,GCTBS ;SET THE TYPE TABLES
POPN 1 ;RETURN TYPE NUMBER
JRST MKN
U DEFNUM
U DEFDIF
;GENERAL USER CONS
USRCNS: SKIPN 1
JRST .+5 ;NO ARGS
MOVEI 6,0(1) ;SAVE NUMBER OF ARGS
MOVEI 5,(PP)
SUBI 5,0(1) ;POINT TO ARGS
HRRZ 1,(5) ;GET TYPE NUMBER
CALL NALLOC ;GET AN ITEM
MOVE 10,[HRLM 3,(2)] ;SET UP STORING OPERATION
HRRZ 2,(5)
HRRZ 7,TYPSIZ-ASZ(2) ;GET NUMBER OF POINTERS
MOVEI 2,0(1)
USRC1: JUMPE 7,NALOC1 ;EXIT IF ALL PTRS FILLED
ADDI 5,1 ;BUMP ARG PTR
SUBI 6,1 ;DEC NUMBER OF ARGS LEFT
JUMPLE 6,USRC2 ;RAN OUT OF ARGS?
HRRZ 3,(5) ;NO
JRST .+2
USRC2: MOVE 3,KNIL ;YES - USE NIL
XCT 10 ;STORE THE DATA
TLC 10,44000 ;FLIP BETWEEN HRLM AND HRRM
TLNN 10,40000 ;BACK TO HRLM?
AOJ 2, ;YES - BUMP DATA PTR
SOJA 7,USRC1 ;DEC. NUMBER OF PTRS AND LOOP
;GET NUMBER OF POINTERS
GTNPTR: CAIL 1,MSYST+1+ASZ ;CHECK DATA TYPE NUMBER
CAIL 1,MTYPN+ASZ
ERROR1 41,GTNPTR
CALL IUNBOX
HRRZ 1,TYPSIZ(1)
JRST MKN
;GET NUMBER OF WORDS
GTNWRD: CAIL 1,MSYST+1+ASZ ;CHECK DATA TYPE NUMBER
CAIL 1,MTYPN+ASZ
ERROR1 41,GTNWRD
CALL IUNBOX
HRRZ 1,TYPBLK(1)
HLRZ 1,TSIZ(1)
JRST MKN
;SET TYPE STATUS
;NIL = RETURN CURRENT STATUS
;0 = FREE TYPE
;1 = IN USE
;2 = A DEALOCATED TYPE
TYPSTS: CAIL 1,MSYST+1+ASZ ;CHECK DATA TYPE NUMBER
CAIL 1,MTYPN+ASZ
ERROR1 41,TYPSTS
CAMN 2,KNIL
JRST TYSTS1
HRRZ 1,2(VP)
CALL IUNBOX
HRRZ 2,1(VP)
MOVE 3,TYPSIZ-ASZ(2)
HRLM 1,TYPSIZ-ASZ(2)
HLR 1,3
JRST MKN
TYSTS1: HLRZ 1,TYPSIZ-ASZ(1)
JRST MKN
;DEFEVAL - DEFINE THE EVALUATION FUNCTION FOR A GIVEN DATA TYPE
;ARG1 = THE NUMBER OF THE DATA TYPE (CANNOT BE LIST, ATOM, OR NUMBER)
;ARG2 = T OR EVAL => ITEM EVALS TO ITSELF (THE INITIAL SETTING)
; = NIL => DO NOT RESET THE EVALUATION FUNCTION
; = A FUNC. NAME => ARG2 WILL BE CALLED WHEN THIS TYPE IS EVAL'ED
;RETURNS: NIL IF THE TYPE NUMBER IS ILLEGAL
; THE PREVIOUS EVALUATION FUNCTION OR
; T IF THE TYPE CURRENTLY EVALS TO ITSELF.
DEFEVA: CALL IUNBOX ;UNBOX THE TYPE NUMBER
SKIPL 1 ;VALID TYPE?
CAIL 1,MTYPN
JRST DFEVA4 ;NO
HRRZ 3,EVATAB(1) ;YES - CAN USER EVAL THIS TYPE?
CAIN 3,-1
JRST DFEVA4 ;NO
SKIPN 3 ;YES - WAS EVALING TO SELF?
MOVE 3,KT ;YES - RETURN T
HRRZ 2,2(VP) ;NO - GET NEW EVAL FN.
CAMN 2,KNIL ;CHANGING THE EVAL. FN?
JRST DFEVA2 ;NO
CAME 2,KT ;YES - FN=T OR EVAL?
CAMN 2,KEVAL
SETZ 2, ;YES - SET TO ZERO
HRRM 2,EVATAB(1) ;NO - SAVE THE NEW FN.
DFEVA2: MOVEI 1,0(3) ;RETURN PREV. EVAL. FN.
RET
DFEVA4: HRRZ 1,1(VP)
ERROR1 41,R
;DEFPRINT - DEFINE THE PRINTING FUNCTION FOR A GIVEN DATA TYPE
;ARG1 = THE NUMBER OF THE DATA TYPE (CANNOT BE LIST, ATOM, OR NUMBER)
;ARG2 = T => PERFORM THE SYSTEM'S DEFAULT PRINTING FOR THIS TYPE
; = NIL => DO NOT RESET THE PRINTING FN, JUST RETURN THE CURRENT FN.
; = A FN NAME => ARG2 WILL BE CALEED WHEN THIS TYPED IS PRINTED.
;RETURNS: THE PREVIOUS PRINTING FN OR
; T IF THE DEFAULT IS CURRENTLY IN EFFECT.
DEFPRI: CALL IUNBOX ;UNBOX THE TYPE NUMBER
SKIPL 1 ;VALID TYPE?
CAIL 1,MTYPN
JRST DFEVA4 ;NO
HLRZ 3,EVATAB(1) ;YES - CAN USER PRINT THIS TYPE?
CAIN 3,-1
JRST DFEVA4 ;NO
SKIPN 3 ;YES - WAS SYS. DEFLT?
MOVE 3,KT ;YES - RETURN T
HRRZ 2,2(VP) ;NO - GET NEW PRINT FN.
CAMN 2,KNIL ;CHANGING THE PRINT FN?
JRST DFPRI2 ;NO
CAMN 2,KT ;YES - FN=T?
SETZ 2, ;YES - SET TO ZERO
HRLM 2,EVATAB(1) ;NO - SAVE THE NEW FN.
DFPRI2: MOVEI 1,(3)
RET
;ALLOCATE SPACE FOR ARRAY - ARG IS NUMBER OF WORDS
ALLOCA: CALL IUNBOX
ALLOC1: TLNN 1,-1
CAIG 1,1
JRST ALLOCE ;INSANE LENGTH
MOVEI 2,0(1)
ADD 1,FREEAR
CAMG 1,ENDAR
JRST ALLOC2
MOVEI 1,0(2) ;WON'T FIT, MUST GC
PUSHJ GP,ARRGC
MOVEI 1,0(2)
ADD 1,FREEAR
CAMLE 1,ENDAR
ERROR0 25,RESET ;STILL WONT FIT,GIVE UP
ALLOC2: EXCH 1,FREEAR
HRRZM 2,0(1) ;SET LENGTH
SETZM 1(1) ;SET GC PTR AND PTR PTR TO 0
MOVEI 3,0(1) ;CHECK FOR FIRST ARRAY THIS PAGE
LSH 3,-LPS
HRRZ 2,BTT(3)
CAIN 2,0
HRRM 1,BTT(3) ;YES, ENTER IN BTT
RET
ALLOCE: CALL MKN
ERROR1 33,RESET
;ELT(ARRAY POSITION)
ELT: PUSH PP,[1]
SKIPA
ELTD: PUSH PP,[0]
LDT 2,1 ;CHECK TYPE
CAIN 2,HANDLT ;SWAPPED?
JRST SWAPPD ;YES
CAIE 2,ARRAYT ;NO - BETTER BE AN ARRAY
ERROR1 34,RESET
MOVEI 3,0(1)
CALL FBA
CAIE 1,0(3)
ERROR1 34,RESET ;MUST BE ARRAY BEG.
ELT2: HRRZ 1,2(VP) ;POSITION
CALL IUNBOX
HRRZ 4,1(VP) ;ARRAY POINTER
HRRZ 3,1(4)
MOVEI 2,0(1)
ADDI 4,1(1)
MOVE 1,0(4)
POP PP,4
CAILE 3,1(2)
JRST MKN
TRNN 4,1
HLRZ 1,1
MOVEI 1,0(1)
RET
SWAPPD: CALL RFNPOS ;SWAP IT IN
SUBI 1,2 ;POINT TO HEADER
JRST ELT2
;ARRAY(LENGTH,#UNBOXED,INIT)
ARRAY: CALL IUNBOX
ADDI 1,2
CALL ALLOC1 ;GET LENGTH+2 WORDS
PUSH PP,1 ;SAVE ARRAY ADDR
HRRZ 1,2(VP)
CAMN 1,KNIL
TRZN 1,-1 ;NIL MEANS 0
CALL IUNBOX
ADDI 1,2
POP PP,2 ;ARRAY POINTER
HRRM 1,1(2) ;SET RELATIVE LOC. OF POINTERS
CAML 1,0(2)
JRST R2 ;NO POINTERS TO INITIALIZE
ADDI 1,1(2)
HRLI 1,-1(1)
HRRZ 3,3(VP) ;INIT VAL FOR POINTERS
HRLI 3,0(3)
MOVEM 3,-1(1)
MOVEI 3,0(2)
ADD 3,0(2)
CAIE 3,0(1) ;EXACTLY ONE POINTER?
BLT 1,-1(3)
JRST R2
;PREDICATE
ARRAYP: LDT 2,1
CAIE 2,ARRAYT
JRST FALSE
RET
;GET BLOCK OF UNMOVABLE STORAGE
;1 - NUMBER OF PAGES
GETBLK: CALL IUNBOX
PUSHN 1
JUMPLE 1,GETBE ;ERROR
MOVEI 5,0(1)
CALL MTPGS ;LOOK FOR EMPTY PAGES
JRST GETBE ;CANT FIND
MOVEI 1,0(4)
MOVN 2,0(CP)
MOVEM 4,0(CP)
HRLI 1,0(2)
MOVEI 3,BLOCKT
CALL CLRPG
MOVEM 3,TYPTAB(1)
AOBJN 1,.-2
POPN 1
LSH 1,LPS
RET ;RETURN ADDRESS OF FIRST PAGE
GETBE: HRRZ 1,1(VP)
ERROR1 35,RESET
;RELEASE A BLOCK 1 - ADDR OF BEGINNING, 2- NUMBER PAGES
RELBLK: MOVEI 1,0(2)
CALL IUNBOX
JUMPLE 1,RELBE
HRRZ 2,1(VP)
LSH 2,-LPS
MOVNI 3,0(1)
HRLI 2,0(3)
PUSHN 2
RELB1: HRRZ 1,TYPTAB(2) ;CHECK THAT PGS REALLY BLOCK
ANDI 1,77
CAIE 1,BLOCKT
JRST GETBE ;NOT BLOCK - ERROR
AOBJN 2,RELB1
POPN 2
SETZM TYPTAB(2)
AOBJN 2,.-1
HRRZ 1,2(VP) ;RET # PAGES
RET
RELBE: HRRZ 1,2(VP)
ERROR1 35,RESET
;GET HASH - 1 PTR, 2 ARRAY
GETHSH: STN 2,LIST ;SECOND ARG LIST
CARA 2,2 ;CAR IS THE ARRAY
CAMN 2,KNIL
HRRZ 2,@KSYSHSH ;NIL MEANS SYSTEM ARRAY
EXCH 1,2
CALL HSHLK
JRST FALSE
RET
;PUT HASH - 1 PTR, 2 VALUE , 3 ARRAY
PUTHSH: STN 3,LIST
CARA 3,3
CAMN 3,KNIL
HRRZ 3,@KSYSHSH
EXCH 1,3
EXCH 2,3
JUMPE 1,PUTH1
STE 1,ARRAY
ERROR1 34,RESET
PUTH1: CAME 3,KNIL ;VALUE NIL MEANS REMOVE
JRST HSHENT
REMHSH: PUSH PP,1 ;SAVE ARRAY USING
CALL HSHLK
JRST REMH1 ;WASNT THERE
MOVSI 1,1
MOVEM 1,0(4) ;MARK DELETED
ADDM 1,@0(PP) ;DECREASE (NEG) COUNT
REMH1: SUB PP,BHC+1
JRST FALSE
;CLEAR HASH ARRAY
CLRHSH: STN 1,LIST
CARA 1,1
CAMN 1,KNIL
HRRZ 1,@KSYSHSH
JUMPN 1,.+2
CALL HSHLKS
STE 1,ARRAY
ERROR1 34,RESET
HRROS 2,0(1) ;CLEAR COUNT, GET LENGTH
MOVEI 2,0(2)
CAIL 2,3
SETZM 2(1)
CAIG 2,3
JRST CLRHA ;NOTHING TO CLEAR
HRLZI 3,2(1)
HRRI 3,3(1)
ADDI 2,-1(1)
BLT 3,0(2)
CLRHA: HRRZ 1,1(VP)
RET
;HASH LOOKUP AND ENTER - 1 ARRAY, 2 PTR TO TAG, 3 VALUE
HSHLK: SETOM HENTO ;-1 FOR LOOKUP
JRST HSHLK1
HSHENT: SETZM HENTO ;POS. FOR STORING
HSHLK1: PUSH PP,1 ;ARRAY
PUSH PP,3 ;VALUE
JUMPN 1,.+2
CALL HSHLKS
HSHLK2: MOVEI 7,0(2) ;SCRAMBLE PTR
IMUL 7,HASHC ;SAVE 7 FOR REHASH
MOVE 3,7
HRRZ 6,0(1) ;ARRAY LENGTH
IDIVI 3,-2(6) ;REL. ADDR TO PROBE IN 4
MOVEI 3,775(6) ;DIVIDE INTO BUCKETS APPROX PAGE SIZE
LSH 3,-LPS ;# BUCKETS
MOVEI 5,-2(6)
IDIVM 5,3 ;3 HAS BUCKET SIZE
MOVEI 5,0(4)
IDIVI 5,0(3)
ADDI 4,2(1) ;MAKE ADDR ABSOLUTE
SUBM 4,6 ;6 HAS BUCKET ORG
MOVEI 5,0(3) ;5 COUNTS PROBES
HSH1: HLRZ 1,0(4)
CAIG 1,1
JRST HSHLKE ;EMPTY SLOT
CAIE 1,0(2) ;USED - RIGHT ONE?
JRST HSHAGN ; NO - TRY AGAIN
SKIPGE 1,HENTO ;YES - STORING?
JRST HSHRV ;NO - RETURN VALUE
SKIPN 1 ;YES - ANY SAAVED ADDR
JRST HSH2 ;NO - JUST STORE NEW VALUE
HRLI 1,1 ;YES : RECLAIM THIS ONE
HLLZM 1,0(4) ; AND USE EARLIER ONE
MOVEI 4,0(1)
HSH2: MOVSI 2,0(2)
HRR 2,0(PP)
MOVEM 2,0(4) ;STORE PAIR
MOVEI 1,0(2)
HSH3: SUB PP,BHC+2
RET
HSHRV: HRRZ 1,0(4)
AOS 0(CP) ;RETURN SKIPPING
JRST HSH3
HSHLKS: PUSH PP,2 ;FIRST REF TO SYSTEM TABLE
MOVEI 1,NPS
CALL ALLOC1 ;MAKE IT EXIST
MOVEI 2,2
MOVEM 2,1(1)
HRRM 1,@KSYSHSH
POP PP,2
MOVEM 1,-1(PP)
RET
HSHLKE: JUMPE 1,HSHLKU ;UNUSED
SKIPN HENTO ;RECLAIMED - STORING?
HRRZM 4,HENTO ;YES - SAVE FIRST RECLAIMED SLOT SEEN
HSHAGN: JUMPL 5,HSHHRD ;TRY HARDER
SOJLE 5,HSHQ ;DONE NORMAL WAY?
MUL 7,HASHC ;NO - REHASH
ASHC 7,↑D20
MOVE 10,7
IDIVI 10,0(3)
MOVEI 4,0(11)
ADDI 4,0(6)
JRST HSH1
HSHLKU: SKIPGE 1,HENTO ;EMPTY - STORING?
JRST HSH3 ;NO - RETURN BAD
SKIPE 1
MOVEI 4,0(1)
MOVSI 1,-1 ;COUNT NEW ENTRY
ADDM 1,@-1(PP)
JRST HSH2
HSHHRD: AOBJP 5,HSH3 ;LIN. SEARCH DONE TOO - RET BAD
HSH5: MOVEI 4,0(5)
JRST HSH1
HSHQ: TRNN F,GCFLG
SKIPGE HENTO
JRST HSH4 ;IN GC OR SEARCHING - TRY HARDER
HSHFUL: HRRZ 3,-1(PP) ;ELSE ASSUME FULL
HRRZ 4,@KSYSHS
CAIE 3,0(4) ;SYSTEM TABLE?
JRST HSHBAD
PUSH PP,2
HRRZ 1,0(3) ;LENGGGTH
LSH 1,-1
ADD 1,0(3) ;1.5 TIMES LENGTH
MOVEI 1,0(1)
CALL ALLOC1
MOVEI 2,2
MOVEM 2,1(1)
MOVEI 2,0(1)
EXCH 1,-2(PP)
CALL UREHSH
HRRZM 1,@KSYSHS
POP PP,2
JRST HSHLK2
HSH4: MOVN 5,@-1(PP) ;SET UP FOR LINEAR SEARCH
HRLI 5,2(5)
HRR 5,-1(PP)
ADDI 5,2
JRST HSH5
HSHBAD: HRRZ 1,3(VP) ;3RD ARG OF PUTHASH
ERROR1 32,.+1
CARA 1,1 ;ASSUME LIST ELSE DONT GET HERE
HRRM 1,-1(PP)
HRRZ 2,1(VP) ;FIRST ARG OF PUTHASH - THE PTR
STE 1,ARRAY
ERROR1 34,RESET
SETZM HENTO ;INCASE ERROR CHANGED IT
JRST HSHLK2
;EVALA (FORM , ALIST)
EVALA:EVALA1: STE 2,LIST
JRST EVALA2
CARA 3,2
STE 3,LIST
JRST EVALAE
MOVS 3,0(3) ;NAME,VALUE
PUSH PP,3
CDRA 2,2
JRST EVALA1
EVALA2: HRRZ 4,CF ;REVERSE STACKED BINDINGS
MOVSI 2,400000
IORM 2,0(4) ;SET SO PPLOOK WILL SEE IN EXTENSION
GETPPI 4,4
HRRZI 5,0(PP)
EVALA3: ADDI 4,1
CAIL 4,0(5)
JRST EVALA4
MOVE 2,0(4)
EXCH 2,0(5)
MOVEM 2,0(4)
SOJA 5,EVALA3
EVALA4: CALL EVAL ;EVAL FORM
RET
EVALAE: MOVEI 1,0(3)
ERROR1 33,RESET
;MAKE A STRING OUT OF ANYTHING
MKSTR: CALL STRTY ;GET TYPE
CAIN 2,STPTT
RET ;ALREADY IS STRING
MKSTR3: CAIN 2,PNAMT
JRST MKSTRP
CALL MKSTRS ;SET UP TO STORE
CALL IPSTR ;INTERNAL PRINT STRING
JRST MKSP ;BOX STRING POINTER
MKSTRP: HLLZ 2,0(1) ;PNAME-MAKE STRING POINTER TO IT
TLZ 2,3777
LSH 2,-↑D8 ;GET LENGTH
IMULI 1,5 ;ADDR X 5
ADDI 1,1 ;+ 1 CHAR
IOR 1,2 ;LENGTH
JRST MKSP ;BOX
;STORE 1 CHARACTER OF STRING
MKSTR1: SOSGE NFRECH
JRST MKSTR2 ;STRING STORAGE FULL
IDPB 1,FREEST
MOVSI 1,10
ADDM 1,UNP1 ;INCR LENGTH
RET
MKSTR2: HRLM 1,0(CP) ;SAVE CHAR
MOVE 1,UNP1
CALL STRGC ;GARBAGE COLLECT
MOVEM 1,UNP1 ;RETURNS UPDATED STRING POINTER
HLRZ 1,0(CP)
JRST MKSTR1
;SET UP TO STORE STRING
MKSTRS: LDB 4,[POINT 6,FREEST,5] ;CONVERT BYTE PONTER TO STRPTR
MOVEI 3,↑D29
SUB 3,4
IDIVI 3,7 ;CHAR NO. LAST CHAR. PREV. STRING
HRRZ 4,FREEST
IMULI 4,5
ADDI 4,1(3)
MOVEM 4,UNP1 ;STRING POINTER
RET
;STORE A STRING POINTER
MKSP: SKIPN 2,FREESP
JRST MKSP1
EXCH 1,0(2)
EXCH 1,FREESP ;UPDATE FREE
RET
MKSP1: CALL STPTGC
JRST MKSP
;MAKE ATOM OUT OF STRING OR PRINT REP. OF ANYTHING
MKATOM: CALL PACS
CALL MKSTR ;MAKE STRING
SBPC 3,1
JUMPLE 4,MKATM ;NULL STRING
ILDB 1,3
CALL PAC
SOJG 4,.-2
JRST MKATM
;SUBSTRING (X N M)
;MAKE X A STRING IF IT ISNT ALREADY
;AND RETURN STRING OF CHARS N THRU M OF X
;IF M NIL ASSUME END OF X
;NIL IF X TOO SHORT
SUBSTR: CALL STRTY ;GET TYPE
CAIE 2,STPTT ;STRING?
JRST SUBST1
MOVE 1,0(1) ;YES - MAKE NEW STRING PTR BOX
CALL MKSP
JRST .+2
SUBST1: CALL MKSTR3 ;OTHER TYPES, MAKE STRING
PUSH PP,1 ;SAVE STRING POINTER(NEW OR OLD)
HRRZ 1,2(VP) ;N
CALL IUNBOX
HRRZ 6,0(PP)
MOVE 6,0(6)
LSH 6,-↑D21 ;ORIG LEN
SKIPG 7,1 ;N NEGATIVE?
ADDI 7,1(6) ;YES - N←N+LEN+1
JUMPLE 7,FALSE
SUBI 7,1
PUSHN 6,2
PUSH CP,7 ;SECOND NUMBER
HRRZ 1,3(VP) ;M
CAMN 1,KNIL
SKIPA 1,6 ;M NIL , USE LENGTH
CALL IUNBOX
POP CP,7
POPN 6
JUMPG 1,.+2 ;M NEGATIVE?
ADDI 1,1(6) ;YES - M←M+LEN+1
CAILE 1,0(6)
JRST FALSE ;M GREATER LENGTH
SUB 1,7 ;M-N+1=NEW LENGTH
JUMPLE 1,FALSE ;TOO SHORT
DPB 1,SUBBP ;PUT IN LENGTH
SUBST2: POP PP,1
ADDM 7,0(1) ;ADD N-1 TO POS.
RET
SUBBP: POINT 14,@0(PP),14
;GET NEXT CHARACTER (X)
;MAKE X A STRING IF IT ISNT
;RETURNS NEXT CHARACTER OF STRING AND INCREMENTS STRING POINTER
;RETURNS NIL IF STRING IS EMPTY
GNC: CALL MKSTR
MOVE 4,0(1)
USBPC 2,4
ADD 4,[-7777777] ;LENGTH-1 AND CHAR. POS. + 1
JUMPL 4,FALSE ;RAN OFF END
MOVEM 4,0(1)
ILDB 1,2
MK1ATM: CALL PACS ;RETURN ATOM
CALL PAC ;*****MAKE 1 CHAR ATOMS SOON
JRST MKATM
;GET LAST CHARACTER AND DECREMENT STRING POINTER
GLC: CALL MKSTR
MOVE 4,0(1)
LSH 4,-↑D21 ;ORIG LENGTH
JUMPLE 4,FALSE ;STRING EMPTY
ADD 4,0(1) ;ADD LENGTH TO POINTER
SUBI 4,1
MOVE 3,[-10000000]
ADDM 3,0(1) ;SUBTR. 1 FROM ORIG. LENGTH
USBPC 2,4
ILDB 1,2
JRST MK1ATM
;CONCAT(X Y... Z)
;CONCATENATE (COPIES OF) ANY NUMBER OF STRINGS
;ARGS TRANSFORMED TO STRINGS IF ARENT ALREADY
CONCAT: MOVNI 7,0(1)
CALL MKSTRS ;SET UP TO STORE STRING
JUMPE 7,CONCA1 ;NO ARGS - RET NULL STRING
MOVEI 6,1(VP)
SUB 6,7
HRLI 6,7
HRRZ 1,@6
CALL CONC1 ;STORE AT END OF STRING STORAGE
AOJL 7,.-2
JRST MKSP
CONCA1: MOVE 1,UNP1
JRST MKSP
CONC1: CALL STRTY ;GET TYPE
CAIN 2,STPTT
JRST COPST1 ;STRING - COPY IT
CAIN 2,PNAMT
JRST COPPN1 ;PNAME - COPY
IPSTR: MOVEI 2,MKSTR1 ;OTHER TYPES USE INTERNAL PRINT
CALL IPRE
CONC2: MOVE 1,UNP1 ;GET POINTER
RET
COPSTR: CALL MKSTRS ;SETUP
COPST1: SBPC 2,1 ;CONVERT TO BYTE PTR
COPST3: JUMPLE 3,COPST4 ;LENGTH 0 OR NEG. ?
PUSH CP,2 ;BYTE PTR TO STACK SO GC WILL UPDATE IT
COPST2: ILDB 1,0(CP) ;COPY STRING
CALL MKSTR1
SOJG 3,COPST2
POP CP,2
COPST4: MOVE 1,UNP1 ;RETURN UNBOXED STRING POINTER
RET
COPPNM: CALL MKSTRS ;PNAME - SETUP
COPPN1: HRLI 1,440700 ;MAKE BYTE POINTER
ILDB 3,1 ;GET LENGTH
MOVE 2,1
JRST COPST3 ;AND COPY
STRTY: LDT 2,1 ;GET TYPE
CAIE 2,ATOMT ;ATOM?
RET ;NO - OK
HLRZ 1,2(1) ;ATOM - GET TYPE OF PNAME
JRST STRTY
;RPLSTR(STR1 N STR2)
;REPLACE STRING 1 BEGINNING AT CHARACTER N BY STRING 2
;CONVERTS ARGS TO STRINGS
;RETURNS STRING 1, WILL BE DIFFERENT IF WASNT STRING
;ERROR IF STRING 2 TOO LONG.... STRING1 MAY BE SMASHED
RPLSTR: CALL STRTY ;GET TYPE
CAIN 2,STPTT
JRST RPLSTS
CALL MKSTRS ;NOT STRING - SET UP TO MAKE ONE
CAIN 2,PNAMT
JRST RPLSTP
CALL IPSTR ;INTERNAL PRINT
RPLST3: CALL MKSP ;BOX STRING POINTER
RPLST2: PUSH PP,1 ;SAVE STRING PTR(NEW OR OLD)
HRRZ 1,2(VP) ;N
CAMN 1,KNIL
SKIPA 1,[1] ;NIL MEANS 1
CALL IUNBOX
JUMPG 1,RPLST5
HRRZ 2,0(PP) ;N NEGATIVE
MOVE 2,0(2) ;... GET LENGTH
LSH 2,-↑D21 ;... OF STRING1
ADDI 1,1(2) ;...AND ADD TO N+1
JUMPLE 1,RPLERR
RPLST5: SUBI 1,1
IMUL 1,[-7777777]
MOVE 2,0(PP)
ADD 1,0(2) ;PTR TO SUBSTR(STRING1 N)
JUMPL 1,RPLERR ;STRING1 LESS N LONG
USBPC 4,1
HRRZ 1,3(VP)
CALL STRTY
CAIN 2,STPTT
JRST RPLS1
CAIN 2,PNAMT
JRST RPLP1
MOVEM 4,UNP1 ;BYTE POINTER
MOVEM 5,UNP2 ;LENGTH REMAINING
MOVEI 2,RPLST1
CALL IPRE
RPLST4: POP PP,1
RET
RPLST1: SOSGE UNP2 ;SUBR CALLED FROM IPRE
JRST RPLERR
IDPB 1,UNP1
RET
RPLSTS: MOVE 2,0(1) ;FIRST ARG IS STRING
TLZ 2,777770
IDIVI 2,5 ;CHECK LOC OF CHARACTERS
LDT 2,2
CAIE 2,PNAMT
JRST RPLST2
CALL COPSTR ;IN PNAME SPACE - COPY
HRRZ 2,1(VP)
MOVEM 1,0(2) ;SMASH NEW POINTER INTO OLD SLOT
JRST RPLST2
RPLSTP: CALL COPPN1 ;PNAME - COPY
JRST RPLST3
RPLS1: SBPC 2,1
RPLS3: CAMLE 3,5
JRST RPLERR
JUMPE 3,RPLST4
RPLS2: ILDB 1,2
IDPB 1,4
SOJG 3,RPLS2
JRST RPLST4
RPLP1: HRLI 1,440700 ;SECONG ARG PNAME
ILDB 3,1 ;GET LENGTH
MOVE 2,1
JRST RPLS3
RPLERR: HRRZ 1,3(VP)
ERROR1 33,RESET
;I-O RELATED FUNCTIONS
RADIKS: CAMN 1,KNIL
JRST RDKS1
CALL IUNBOX
EXCH 1,URADIX
TLZN F,PNEGF ;TEST CURRENT FLAG
MOVN 1,1 ;0 - RET NEG VAL
MOVE 2,URADIX
CAIL 2,0
TLO F,PNEGF ;NEW VAL POS, SET FLAG 1
MOVMM 2,URADIX
MOVEM F,TFLGS
JRST MKN
RDKS1: MOVE 1,URADIX
TLNN F,PNEGF
MOVN 1,1
JRST MKN
OPENP: CAMN 1,KNIL
JRST OPNLST
CALL OPENP1 ;SEARCH FOR INPUT OR OUTPUT FILE
JRST FALSE ;FAILS
RET
OPENP1: CAMN 2,KNIL
JRST FSCH ;ANY OPEN FILE
CAMN 2,KOUTPUT
JRST OPENP2
CAMN 2,KINPUT
CALL IFSCH
JRST IOFSCH ;OPEN FOR INPUT AND OUTPUT
JRST RSKP
OPENP2: MOVEI 2,0(1)
CALL OFSCH ;LOOK FOR OUTPUT FILE
JRST OPNP3 ;NOT FOUND
MOVEI 1,0(2)
JRST RSKP
OPNP3: MOVEI 1,0(2) ;TRY I/O
JRST IOFSCH
;HACK JSYS FN (JSYS # AC1 AC2 AC3 RESULTAC)
UJSYS: CALL IUNBOX
PUSHN 1 ;JSYS NUMBER
HRRZ 1,5(VP)
CAMN 1,KNIL
SKIPA 1,[1] ;DEFAULT RESULT IS AC1
CALL IUNBOX
PUSHN 1
HRRZ 1,4(VP)
CAMN 1,KNIL
SKIPA 1,[0]
CALL IUNBOX
PUSHN 1
HRRZ 1,3(VP)
CAMN 1,KNIL
SKIPA 1,[0]
CALL IUNBOX
PUSHN 1
HRRZ 1,2(VP)
CAMN 1,KNIL
SKIPA 1,[0]
CALL IUNBOX
POPN 2
POPN 3
POPN TP
POPN 5
JSYS 0(5)
JFCL
JFCL ;IGNORE SKIPS
MOVE 1,0(TP) ;DO ANY JSYS'S CLOBBER AC TP?????
JRST MKN ;BOX AC1
NCHARS: CAME 2,KNIL
JRST NCHR4
LDT 2,1 ;GET ARG TYPE
CAIE 2,ATOMT ;ATOM?
JRST NCHR1 ;NOT ATOM
HLRZ 1,2(1)
NCHR3: CALL UPATM ;CONSTRUCT COUNT, POINTER
MOVEI 1,0(4) ;RETURN COUNT
JRST MKN
NCHR1: CAIN 2,STPTT ;STRING?
JRST NCHR3 ;YES -EASY
MOVEI 4,IPRE
NCHR5: SETZM UNP1
MOVEI 2,NCHR2 ;SET UP INTERNAL PRINT
CALL (4)
MOVE 1,UNP1
JRST MKN
NCHR4: MOVEI 4,IPRE2
JRST NCHR5
NCHR2: AOS UNP1
RET
POSITN: MOVE 3,FP
CAMN 1,KNIL ;NIL ARG?
JRST POSN1 ;YES, USE STND OUTPUT FILE
CALL FSCH
JRST ILLIF ;NO SUCH FILE
TRNN 3,-1 ;TTY IN?
MOVEI 3,1 ;YES, USE TTY OUT
POSN1: HRRZ 1,2(VP) ;SECOND ARG GIVEN?
CAMN 1,KNIL
JRST POSN2 ;NO
PUSHN 3
CALL IUNBOX
POPN 3
HRRM 1,CHPOS(3) ;YES - SET POSITION
HRRZ 1,2(VP)
RET
POSN2: HRRZ 1,CHPOS(3) ;POSITION ON LINE
JRST MKN
TERPRI: MOVEI 2,0(1)
CALL OFSET
MOVEI 1,EOL ;PRINT EOL
CALL PREC
JRST FALSE
;PACK AND UNPACK
PACK: CALL PACS ;INITIALIZE ATOM PACKER
PACK1: CAMN 1,KNIL ;END OF LIST?
JRST MKATM ;YES, CONSTRUCT ATOM AND RETURN
PUSH PP,1 ;NO, SAVE LIST
CARA 1,1 ;GET NEXT ELEMENT
MOVEI 2,PAC
CALL IPRE ;INTERNAL PRINT
POP PP,1
CDRA 1,1
JRST PACK1
PACKC: CALL PACS
PACKC1: CAMN 1,KNIL
JRST MKATM
PUSH PP,1
CARA 1,1
CALL IUNBOX
CALL PAC
POP PP,1
CDRA 1,1
JRST PACKC1
UNPACK: SETZM UNP1 ;INITIALIZE LIST
MOVEI 4,IPRE
CAME 2,KNIL ;SECOND ARG NIL?
MOVEI 4,IPRE2 ;NO - USE INTERNAL PRIN2
MOVEI 2,UNP ;INTERNAL SUBR FOR CHARS
CALL (4) ;INTERNAL PRINT
UNP6: SKIPG UNP1
JRST FALSE ;NO CHARACTERS
MOVE 1,UNP2
RET
UNP: CALL SAV27 ;SAVE AC'S 2-7
CALL PACS ;INITIALIZE ATOM PACKER
CALL PAC ;PACK CHARACTER
PUSH PP,UNP2
CALL MKATM
POP PP,UNP2
UNP5: PUSH PP,UNP1 ;GET LAST ON STACK IN CASE GC
MOVE 2,UNP2
CALL CONS
HLRZ 2,0(1)
MOVEM 2,UNP2 ;SAVE LIST SO FAR
MOVE 2,KNIL
HRLM 2,0(1) ;RPLACD (NEW) LAST WITH NIL
POP PP,2 ;GET BACK OLD LAST
JUMPE 2,UNP3 ;NO LIST SO FAR
HRLM 1,0(2) ;RPLACD LAST WITH NEW ELEMENT
UNP4: MOVEM 1,UNP1 ;BECOMES NEW LAST
CALL RES27 ;RESTORE AC'S 2-7
RET
UNP3: MOVEM 1,UNP2 ;IS FIRST (WHOLE) OF LIST
JRST UNP4
U UNP1
U UNP2
CHCON: SETZM UNP1 ;INITIALIZE LIST
MOVEI 4,IPRE
CAME 2,KNIL ;SECOND ARG NIL?
MOVEI 4,IPRE2 ;NO- USE INTERNAL PRIN2
MOVEI 2,CHCN
CALL (4)
JRST UNP6
CHCN: CALL SAV27 ;INTERNAL SUBR FOR CHARS- CHCON
ADDI 1,ASZ ;BOX
JRST UNP5
CHCON1: MOVEI 2,CHCN1
CALL IPRE
JRST FALSE
CHCN1: ADDI 1,ASZ
INTOFF
HRRZ CP,CF
ADDI CP,FLGWD ;FLUSH TEMS OF THIS FRAME
HRLI CP,@ICPC
INTON
RET
NTHCHR: CAME 3,KNIL
JRST NTHCH2
LDT 3,1
CAIN 3,STPTT
JRST NTHC3
CAIE 3,ATOMT
JRST NTHCHN
HLRZ 1,2(1)
HRRM 1,1(VP)
NTHC3: MOVEI 1,0(2)
CALL IUNBOX
MOVE 7,1
HRRZ 1,1(VP)
CALL UPATM
SKIPGE 7
ADDI 7,1(4)
JUMPLE 7,FALSE
CAILE 7,0(4)
JRST FALSE
SUBI 7,1
IDIVI 7,5
ADDI 3,0(7)
IBP 3
SOJGE 10,.-1
NTHC1: LDB 1,3
NTHC2: CALL PACS
CALL PAC
JRST MKATM
NTHCH2: MOVEI 3,IPRE2
SKIPA
NTHCHN: MOVEI 3,IPRE
MOVEM 3,NTHCP
MOVEI 1,0(2)
CALL IUNBOX
JUMPG 1,NTHC4
PUSHN 1
HRRZ 1,1(VP)
SETZM UNP1 ;NTHCHAR WITH NON-STRING OR ATOM
MOVEI 2,NCHR2 ;...AND NEG. COUNT
HRRZ 3,4(VP) ;...AND READTABLE
CALL @NTHCP ;...IS SLOW, BUT SERVES ONE RIGHT
POPN 1
ADD 1,UNP1
ADDI 1,1
JUMPLE 1,FALSE
NTHC4: MOVEM 1,UNP1
MOVEM CP,UNP2
HRRZ 1,1(VP) ;GET ARG BACK
MOVEI 2,NTHCC ;ROUTINE FOR INTERNAL PRINT
HRRZ 3,4(VP) ;READTABLE
CALL @NTHCP ;INTERNAL PRINT
JRST FALSE ;TOO FEW CHARACTERS
NTHCC: SOSLE UNP1
RET
MOVE CP,UNP2 ;RESTORE CP
JRST NTHC2 ;AND MAKE ATOM
CHRCT: CALL IUNBOX ;CHARACTER, UNBOX NUMBER
JRST NTHC2 ;AND MAKE ATOM
U NTHCP
;DATE AND TIME FNS
IFN TEN50,<
DATE: CALL PACS
MOVEI 2,↑D10 ;SETUP SUBROUTINES
MOVEM 2,APTR ;RADIX
MOVEI 2,PAC ;CHARACTER SINK
MOVEM 2,PREX
CALLI 1,14 ;DATE
IDIVI 1,↑D31*↑D12
PUSH CP,1 ;SAVE YEAR
MOVEI 1,0(2)
IDIVI 1,↑D31
PUSH CP,2 ;SAVE DAY
ADDI 1,1
CALL DATE1 ;MONTH
TCH "/"
POP CP,1
ADDI 1,1
CALL DATE1 ;DAY
TCH "/"
POP CP,1
ADDI 1,↑D64
CALL DATE1 ;YEAR
TCH " "
CALLI 1,23 ;DAYTIME IN MILLISECONDS
IDIVI 1,↑D1000 ;CONVERT TO SECONDS
IDIVI 1,↑D3600
PUSH CP,2 ;SAVE SECONDS THIS HOUR
CALL DATE1 ;HOUR
POP CP,1
IDIVI 1,↑D60
PUSH CP,2 ;SAVE REMAINING SECONDS
CALL DATE1 ;MINUTES
TCH ":"
POP CP,1
CALL DATE1 ;SECONDS
JRST MKATM
DATE1: CAIGE 1,↑D10 ;ALWAYS PRINT TWO DIGITS
TCH "0" ;LEADING ZERO
JRST APT1
>
;SET FILE POINTER
IFE TEN50,<
SPTR: CAMN 1,KNIL
JRST SFPT5
CALL FSCH
ERROR1 15,RESET ;FILE NOT OPEN
MOVEI FX,0(3)
SKIPA
SFPT5: MOVE FX,FR ;USE STANDARD INPUT FILE
MOVEM FX,FRX
HRRZ 1,FILEN(FX)
RFPTR ;GET PRESENT FILE PTR
JRST SFPT3
HRRZ 3,FCHAR(FX)
JUMPE 3,SFPT1
SUBI 2,1
CAIN 3,EOL
SUBI 2,1 ;EOL IN LISP IS CR/LF IN SYSTEM
SFPT1: PUSHN 2
HRRZ 1,2(VP)
CAMN 1,KNIL
JRST SFPT2 ;JUST RETURN PRESENT PTR
CALL IUNBOX
MOVE FX,FRX
HLLZS CHPOS(FX)
HLLZS FCHAR(FX)
MOVE 2,1
HRRZ 1,FILEN(FX)
SFPTR
JRST SFPT4
SFPT2: POPN 1
JRST MKN
ILARG1:
SFPT3: HRRZ 1,1(VP)
ERROR1 33,RESET
SFPT4: HRRZ 1,2(VP)
ERROR1 33,RESET
>
IFE TEN50,<
DATE: CAMN 1,KNIL
SKIPA 1,[0]
CALL IUNBOX
MOVE 3,1 ;FLGS FOR WHICH DATE
SETO 2, ;STANDARD FORMAT
MOVE 1,IOFNMP
ODTIM ;DATE AND TIME TO STRING
PUSHN 1
CALL MKSTRS
MOVE 10,IOFNMP
DATE1: ILDB 1,10
CALL MKSTR1
CAME 10,0(CP)
JRST DATE1
POPN 2
MOVE 1,UNP1
JRST MKSP
>
CLOCK: CAMN 1,KNIL
JRST CLK0
CALL IUNBOX
CAIG 1,3
CAIGE 1,0
JRST FALSE
JRST .+1(1)
JRST CLK0
JRST CLK1
JRST CLK2
JRST CLK3
CLK0: TIME ;TIME IN MS
JRST MKN
CLK1: MOVE 1,LOGTOD ;TIME OF STARTUP OF LISP
JRST MKN
CLK2: GETJRT ;RUNTIME THIS JOB
SUB 1,LOGRT ;LESS GC AND STARTUP
SUB 1,GCRT
JRST MKN
CLK3: MOVE 1,GCRT ;GC TIME
JRST MKN
;PUT STRINGS INTO VARIOUS TTY BUFFERS
BKSYSB: CALL BKSET
BKSYS2: JUMPLE 4,FALSE
MOVEI FX,0
HRRZ 1,FILEN(FX)
BKSYS1: ILDB 2,3
STI
SOJG 4,BKSYS1
HRRZ 1,-2(PP) ;OK - RET STRING
RET
BKLNBF: CALL BKSET
JUMPLE 4,FALSE
SKIPLE LNBFC
JRST FALSE ;CANT DO IF BUFFER NOT EMPTY
MOVEM 3,BKLNP
MOVEM 4,BKLNC
CALL GCHIB
HRRZ 1,-2(PP)
RET
BKCHAR: SOSGE BKLNC ;GET CHAR FROM BACKED STRING FOR LNBF
JRST .+3
ILDB 1,BKLNP
JRST RSKP
TLZ F,BKFLG ;FINISH WITH CHARS FROM TTY
RET ;RETURN NO SKIP
BKSET: CALL STRTY
CAIN 2,STPTT
JRST BKSET1
CAIE 2,PNAMT
JRST BKSET2
MOVEI 3,0(1)
HRLI 3,440700
ILDB 4,3
RET
BKSET1: SBPC 3,1
RET
BKSET2: MOVNI 4,1
RET
U BKLNP
U BKLNC
ESCP: SETO 2, ;ARG T TURNS ON ESCAPE CHAR FOR READ
CAMN 1,KNIL
SETZ 2, ;ARG NIL TURN OFF
EXCH 2,ESCONF
JUMPE 2,FALSE ;WAS OFF - RET NIL
JRST TRUE
RDMACS: MOVEI 2,0
CAME 1,KNIL
SETO 2,
EXCH 2,RMONF
JUMPE 2,FALSE
JRST TRUE
LINLTH: CAMN 1,KNIL
SKIPA 1,LINSIZ
CALL IUNBOX
EXCH 1,LINSIZ
JRST MKN
TRAPCT: CAMN 1,KNIL
SKIPA 1,TRPCNT
CALL IUNBOX
EXCH 1,TRPCNT
JRST MKN
U TRPCNT
SETPLV: CAMN 1,KNIL
JRST SETPL1 ;ARG NIL, RETURN CURRENT VAL
CALL IUNBOX
EXCH 1,PPLVL
TLZE F,NEGPLF ;CHECK OLD FLAG
MOVN 1,1 ;SET - RETURN NEG VALUE
MOVE 2,PPLVL
JUMPGE 2,.+3
TLO F,NEGPLF
MOVMM 2,PPLVL
MOVEM F,TFLGS
JRST MKN
SETPL1: MOVE 1,PPLVL
TLNE F,NEGPLF
MOVN 1,1
JRST MKN
READP: CALL IFSET
JUMPN FX,READP1 ;TTY?
SKIPLE LNBFC
JRST TRUE
READP1: HRRZ 1,FCHAR(FX)
HRRZ 3,TTYTBL ;GET THE TERMINAL TABLE
CAMN 2,KNIL ;NO EOL CHECK IF FLG=T
CAME 1,CTLEOL(3) ;IGNORE EOL IN CHAR BUFFER
JUMPN 1,TRUE
CAIN FX,NFILES ;STRING?
JRST READP2 ;YES
HRRZ 1,FILEN(FX) ;NO - IT'S A REAL FILE
SIBE
SKIPA
JRST FALSE
JRST TRUE
READP2: HRRZ 1,FILEA(FX) ;GET THE STRING
MOVE 1,(1) ;GET THE STRING POINTER
TLNE 1,777770 ;TEST THE COUNT - ZERO?
JRST TRUE ;NO
JRST FALSE ;YES
;SET INTERRUPT CHARACTERS
IFE TEN50,<
SETINC: CALL IUNBOX ;WHICH TABLE ENTRY
CAIL 1,UCTCT-CTCT
ERROR1 33,SETINC
PUSHN 1
PIUNBX 2(VP) ;NEW CHAR CODE
MOVE 2,1
CALL OFFINT ;SHUT OFF INTERRUPT CHARS
CALL DISAB1
POPN 3
HLRZ 1,CTCT(3) ;GET OLD CHAR
HRLM 2,CTCT(3)
PUSHN 1
CALL SETINT ;TURN INTERUPT CHARS BACK ON
POPN 1
TRNN 1,400000 ;WAS IT REALLY THERE?
JRST MKN ;YES
JRST FALSE ;NO
;DISABLE INTERRUPT CHARACTER
DISABL: CALL IUNBOX
MOVEI 2,(1)
CALL OFFINT ;SHUT OFF INTERRUPT CHARS
CALL DISAB1
PUSH PP,1
CALL SETINT ;TURN INTERRUPT CHAR BACK ON
POP PP,1
RET
DISAB1: MOVE 4,CTCTP
HLRZ 3,(4)
TRZ 3,400000 ;CLEAR ENABLED/DISABLED BIT
CAIN 3,0(2) ;IS THIS THE CHARACTER?
JRST .+3 ;YES
AOBJN 4,.-4 ;NO - TRY AGAIN
JRST FALSE ;NOT FOUND - RETURN NIL
HLRZ 3,(4) ;GET THE ENTRY SO WE CAN TEST THE BIT
TROE 3,400000 ;GOT IT, DISABLE IT
JRST FALSE ;ALREADY OFF
SETO 3,
HRLM 3,(4)
HRRZI 1,ASZ(4)
SUB 1,CTCTP
TLZ 1,-1
CAMGE 4,UCTCTP ;IS IT A USER SLOT?
RET
SKIPN 1,UCTVAR-UCTCT(4) ;IS THERE A VARIABLE?
HRRZ 1,KT ;NO
RET
; ENABLE INTERRUPT CHARS
ENABLE: SETZM FREICH
CAIG 1,ASZ+↑D30 ;LEGAL CHAR?
CAIGE 1,ASZ
ERROR1 33,ENABLE ;NO
MOVEI 2,-ASZ(1)
CALL OFFINT ;TURN OFF INTERRUPT CHARS
CALL DISAB1 ;DISABLE IT
PUSH PP,1
HRRZ 3,2(VP) ;2ND ARG
CAIN 3,ASZ
JRST ENABL4
MOVE 4,UCTCTP
ENABL2: HLRZ 1,0(4) ;GET ENTRY
TRNN 1,400000 ;EMPTY SLOT?
AOBJN 4,ENABL2 ;NO - TRY AGAIN
SKIPL 4 ;GOT A FREE SLOT?
ERROR0 44,R ;NO
MOVE 1,(4) ;YES - NOW ENABLE THE CHAR
SETZM UCTVAR-UCTCT(4) ;CLEAR THE VAR.
HRL 1,2
TRO 1,400000 ;MAKE HARD
CAMN 3,KT
JRST ENABL5
TRZ 1,400000 ;MAKE SOFT
CAME 3,KNIL ;IS AN INSTANT?
MOVEM 3,UCTVAR-UCTCT(4) ;YES, SET THE VAR
ENABL5: MOVEM 1,(4)
ENABL3: CALL SETINT ;TURN INTERRUPT CHARS BACK ON
POP PP,1
RET
ENABL4: CAME 1,KNIL ;IS IT ENABLED?
HRLM 2,(4) ;YES
JRST ENABL3
U FREICH
>
;GET/SET BRK/SEPR/PRT
SETBRK: MOVEI 6,SBBITS
JRST SETBSS
SETSEP: MOVEI 6,SSBITS
JRST SETBSS
SETBR1: MOVE 4,[Z ORGRDT+2+RDNUBW(1)]
CAME 5,SYSRT2 ;ARE WE RESETTING SYSTEM TABLE?
MOVE 4,SYSRT2 ;NO, RESET FROM SYSTEM RATHER THAN ORIG.
MOVEI 1,177
SETBR2: MOVE 2,@4
MOVE 3,@5
TDNN 2,1(6) ;IS BIT SET IN ORIGINAL?
JRST .+4 ;NO
TDNN 3,1(6) ;YES - IS BIT ALREADY SET?
HLL 3,0(6) ;NO - MAKE IT A BREAKCHAR OR A SEPRCHAR
JRST .+3 ;YES - DO NOTHING
TDNE 3,1(6) ;IS BIT ALREADY SET (IT'S NOT IN ORIG)
HRLI 3,0 ;YES, MAKE IT A REGULAR LETTER
MOVEM 3,@5
SOJGE 1,SETBR2
JRST FALSE
SETBSS: MOVEI 5,(1)
MOVEI 1,(3)
CALL GETRDT
EXCH 1,5
ADD 5,[Z RDNUBW+2(1)]
CAMN 1,KT
JRST SETBR1
CAMN 1,KNIL
JRST STBS1A
LDT 7,1
CAIE 7,LISTT
ERROR1 33,R
STBS1A: MOVEI 7,0(2)
CAMN 7,KNIL
JRST SETBS7
SETBS3: CAMN 1,KNIL ;MORE CHARS?
JRST STBS10
PUSH PP,1
CARA 1,1 ;NEXT CHAR
LDT 2,1
CAIN 2,SMALLT ;NUMBER?
JRST SETBS1 ;YES, IS CHARACTER CODE
CAIN 2,STPTT
JRST SETBS6
CAIE 2,ATOMT
JRST ARGNA
HLRZ 1,2(1)
SETBS6: CALL UPATM
ILDB 1,3
SETBS2: MOVE 2,@5
CAMN 7,KNIL ;SET?
JRST SETBS9 ;YES
CAIE 7,ASZ ;NO - CLEAR IT?
JRST SETBS8 ;NO - ADD
SETZM @5 ;YES - MAKE IT A REGULAR LETTER
JRST SETBS5
SETBS8: TDNE 2,1(6) ;ADD - IS BIT ALREADY SET?
JRST SETBS5 ;YES - DO NOTHING
MOVE 2,0(6) ;NO - SET TO BREAKCHAR OR SEPRHAR
HLLM 2,@5
SETBS5: POP PP,1
CDRA 1,1 ;REST OF LIST
JRST SETBS3
SETBS1: MOVEI 1,-ASZ(1)
JRST SETBS2
SETBS7: SETZM TMPBLK
SETZM TMPBLK+1
SETZM TMPBLK+2
SETZM TMPBLK+3
JRST SETBS3
SETBS9: IDIVI 1,40
MOVNI 2,(2)
MOVSI 4,400000
ROT 4,(2)
IORM 4,TMPBLK(1)
JRST SETBS5
STBS10: CAME 7,KNIL ;SET?
JRST FALSE ;NO
MOVEI 1,177 ;YES
STBS11: MOVEI 3,(1)
IDIVI 3,40
MOVNI 4,(4)
MOVSI 2,400000
ROT 2,(4)
MOVE 3,TMPBLK(3)
TDNE 3,2
JRST STBS12
MOVE 2,@5
TDNN 2,1(6)
JRST STBS13
SETZ 2,
JRST STBS14
STBS12: MOVE 2,@5
TDNN 2,1(6)
SKIPA 2,0(6)
STBS14: CAME 2,@5 ;SO A PAGE WON'T GET UNSHARED
HLLM 2,@5
STBS13: SOJGE 1,STBS11
JRST FALSE
SBBITS: XWD BRKBIT+PRTBIT,0
XWD BRKBIT,0
SSBITS: XWD SEPBIT+PRTBIT,0
XWD SEPBIT,0
SPBITS: XWD PRTBIT,0
XWD PRTBIT,0
U TMPBLK,4
GETBRK: MOVSI 6,BRKBIT
JRST GETBSS
GETSEP: MOVSI 6,SEPBIT
GETBSS: MOVEI 2,(1) ;SELECT WHICH READTABLE
CALL IRTSET
MOVEI 1,177 ;CONSTRUCT LIST OF CHARACTER CODES
PUSH PP,KNIL ;INIT LIST
GETBS2: MOVE 3,@BSTAB ;GET A CHARACTER ENTRY
TDNN 3,6 ;IS THE BIT SET?
JRST GETBS1 ;NO
MOVEI 2,0(1) ;YES, CONS ITS CODE ONTO LIST
CALL SAV27
MOVEI 1,ASZ(2) ;MAKE CHAR INTO (SMALL) NUMBER
MOVE 2,0(PP) ;LIST
CALL CONS
MOVEM 1,0(PP)
CALL RES27 ;RESTORE AC'S 2-7
MOVEI 1,0(2)
GETBS1: SOJGE 1,GETBS2
POP PP,1
RET
; READTABLE CONSTANTS AND FLAGS
EOLBIT==4000
IMEDBT==2000
ALONBT==1000
FRSTBT==400
BRKBIT==200
SEPBIT==100
PRTBIT==40
STRBIT==20
ESCBIT==10
RDTMSK==350
JPBITS==7
RDNUBW==0 ;NUMBER OF UNBOXED WORDS IN A READTABLE
RTSIZE==200+RDNUBW ;SIZE OF A READTABLE ARRAY
JMPFLD: POINT 3,@BSTAB,17
; THE ORIGINAL SYSTEM READTABLE
ORGRDT:
BLOCK 2 ;DUMMY HEADER
REPEAT 9,<0> ;NULL-↑H
SEPBIT+PRTBIT,,0 ;TAB
SEPBIT+PRTBIT,,0 ;LF
0 ;↑K
SEPBIT+PRTBIT,,0 ;↑L
SEPBIT+PRTBIT,,0 ;CR
REPEAT 21,<0> ;↑N-RS
SEPBIT+PRTBIT,,0; EOL
SEPBIT+PRTBIT,,0 ;SPACE
0 ;!
BRKBIT+STRBIT+PRTBIT,,0;"
0 ;#
0 ;$
ESCBIT+PRTBIT,,0 ;%
0 ;&
0 ;'
BRKBIT+PRTBIT+3,,0 ;(
BRKBIT+PRTBIT+4,,0 ;)
REPEAT <"Z"-"*"+1>,<0>;* - Z
BRKBIT+PRTBIT+2,,0 ;[
0 ;\
BRKBIT+PRTBIT+1,,0 ;]
REPEAT <200-"↑">,<0> ;↑ - RUBOUT
;TERMINALTABLE CONSTANTS
TTYSIZ==↑D16 ;SIZE OF TERMINAL TABLE
CTLA==2
CTLQ==3
CTLR==4
CTLV==5
CTLEOL==6
CCOCW1==7
CCOCW2==10
CTQMSG==11
CAMSG1==12 ;FIRST ↑A MESSAGE
CAMSG2==13 ;NTH ↑A MESSAGE
CAMSGP==14 ;POST ↑A MESSAGE
CAMSGE==15 ;EMPTY BUFFER ↑A MESSAGE
ECHFLG==16 ;NO ECHO DELETED ↑A FLAG
LBFLGW==17 ;NO LINE BUFFERING FLAG WORD
ECHMDW==20 ;ECHO MODE WORD
RASMOD==21 ;RAISE MODE WORD
;ORIGINAL SYSTEM TERMINAL TABLE
;
ORGTTY:
BLOCK 2
"A"-100 ;CHAR DELETE
"Q"-100 ;LINE DELETE
"R"-100 ;RETYPE
"V"-100 ;CONTROL V
37 ;EOL
BYTE (2) 0,0,1,1,1,1,1,2,1,3,2,1,1,2,1,1,1,0
BYTE (2) 0,1,1,1,1,1,1,1,1,3,1,1,1,2
ASCIZ/##
/ ;↑Q MESSAGE
ASCIZ/\/ ;↑A MESSAGES
0
ASCIZ/\/
ASCIZ/##
/
0 ;NO ECHO DELETE ↑A FLAG
0 ;NO LINE BUFFERING FLAG
1 ;ECHO MODE
-1 ;RAISE MODE,p= IS 0, < IS NIL, > IS T
; SETREADTABLE(RDTBL,TBLFLG)
SETRDT: CALL GETRDT
CAMN 2,KNIL ;SETTING CURRENT TABLE?
JRST .+3 ;YES
MOVEI 3,SYSRDT ;NO
CAIA
MOVEI 3,CURRDT
EXCH 1,(3) ;SET READTABLE
MOVEI 2,CURRT2 ;SET PRT TO CHAR. DATA
CAIE 3,CURRDT
MOVEI 2,SYSRT2
MOVE 3,(3)
ADD 3,[Z 2+RDNUBW(1)]
MOVEM 3,(2)
RET
; GETREADTABLE(RDTBL)
GETRDT: CAME 1,KNIL ;IS SOURCE THECURRENT TABLE
JRST .+3 ;NO
MOVE 1,CURRDT ;YES
RET
CAME 1,KT ;IS SOURCE THE SYSTEM TABLE?
JRST .+3 ;NO
MOVE 1,SYSRDT ;YES
RET
CALL CKRDTS ;IS IT A READTABLE?
ERROR1 46,R ;NO
RET
; COPYREADTABLE(RDTBL)
CPYRDT: CAMN 1,KORIG
JRST .+3
CALL GETRDT
CAIA
MOVEI 1,ORGRDT
PUSH PP,1
CALL RTALOC
POP PP,2
JRST RTCPY
RTALOC: MOVEI 1,RTSIZE+2 ;ALLOCATE A READTABLE
CALL ALLOC1 ;THIS IS A QUICK AND DIRRTY (ARRAY ...)
MOVEI 2,RDNUBW+2 ;...MUST BE DONE THIS WAY CAUSE IT
HRRM 2,1(1) ;CALLED DURING INITIALIZATION
RET
RTCPY: PUSH PP,1 ;COPY A READTABLE
HRL 1,2 ;BUILD BLT DATA
ADD 1,BHC+2
MOVEI 4,RTSIZE-1(1)
BLT 1,(4) ;COPY
POP PP,1
CAIE 2,ORGRDT
RET
MOVE 3,KNIL ;FILL OUT FNS WITH NIL
MOVEI 2,(1)
ADD 2,[-200,,RDNUBW+2]
HRRM 3,(2)
AOBJN 2,.-1
RET
; RESETREADTABLE(RDTBL,reset/RDTBL)
RSTRDT: CALL GETRDT
EXCH 1,2
CAMN 1,KORIG
JRST .+3
CALL GETRDT
CAIA
MOVEI 1,ORGRDT
EXCH 1,2
CALL RTCPY
RET
; READTABLEP(RDTBL)
RDTBLP: CALL CKRDTS ;USER ENTRY FOR READTABLEP
JRST FALSE
RET
CKRDTS: LDT 4,1 ;SKIP RETURN IF A READTABLE
CAIE 4,ARRAYT ;ARRAY?
RET ;NO
HRRZ 4,(1) ;YES - RIGHT LENGTH?
CAIE 4,RTSIZE+2
RET ;NO
HRRZ 4,1(1) ;YES - CORRECT NUMBER OF UNBOXED WORDS?
CAIN 4,RDNUBW+2
AOS (CP) ;YES
RET ;NO
; SET INPUT READTABLE FROM AC 2, ACS 1 AND 4 ARE CHANGED
IRTSET: MOVE 1,CURRT2
CAMN 2,KNIL ;CURRENT TABLE?
JRST IRTST1 ;YES
MOVE 1,SYSRT2 ;NO
CAMN 2,KT ;SYSTEM TABLE?
JRST IRTST1 ;YES
MOVEI 1,(2) ;NO
CAMN 1,PRVIRT ;SAME TABLE AS LAST TIME?
JRST IRTST1-1 ;YES
CALL CKRDTS ;IS IT A READTABLE?
ERROR1 46,R ;NO
MOVEM 1,PRVIRT ;YES, SAVE FOR NEXT TIME
ADD 1,[Z RDNUBW+2(1)] ;CONVERT TO INTERNAL USABLE FORM
IRTST1: MOVEM 1,BSTAB ;STORE IT
RET
; SET OUTPUT READTABLE FROM AC 3, ONLY AC 2 IS CHANGED
ORTSET: MOVE 2,CURRT2
CAMN 3,KNIL ;CURRENT TABLE?
JRST ORTST1 ;YES
MOVE 2,SYSRT2 ;NO
CAMN 3,KT ;SYSTEM TABLE?
JRST ORTST1 ;YES
CAMN 3,PRVORT ;SAME TABLE AS LAST TIME?
JRST ORTST2 ;YES
PUSH PP,1 ;NO
PUSH PP,4
MOVEI 1,(3)
CALL CKRDTS ;IS IT A READTABLE?
ERROR1 46,R ;NO
MOVEM 1,PRVORT
ADD 1,[Z RDNUBW+2(1)] ;YES, CONVERT TO INTERNAL USABLE FORM
MOVE 2,1
POP PP,4
POP PP,1
ORTST1: MOVEM 2,PBTAB ;STORE IT
RET
ORTST2: ADD 3,[Z RDNUBW+2(1)]
MOVEM 3,PBTAB
RET
;TERMINALTABLE(TABLE)
TRMTBL: CAME 1,KNIL ;IS IT NIL?
JRST .+3 ;NO
GTTY2: HRRZ 1,TTYTBL ;YES - RETURN CURRENT TABLE
RET
CALL CKTRMT ;NO - MAKE SURE IT IS VALID
ERROR1 47,TRMTBL
EXCH 1,TTYTBL ;SET NEW TABLE
TTCP2: PUSH PP,1
CALL SETMOD ;RESET MODES
POP PP,1 ;RETURN OLD VALUE
RET
CKTRMT: LDT 4,1 ;SKIP RETURN IF A TERMINAL TABLE
CAIE 4,ARRAYT ;ARRAY?
RET ;NO
HRRZ 4,(1) ;RIGHT LENGTH?
CAIE 4,TTYSIZ+2
RET ;NO
HRRZ 4,1(1) ;YES - ARE THEY ALL UNBOXED?
CAIN 4,TTYSIZ+2
AOS (CP) ;YES
RET ;NO
; COPYTERMTABLE(TABLE)
CPYTT: CAMN 1,KORIG
JRST .+3
CALL GETTY
CAIA
MOVEI 1,ORGTTY
PUSH PP,1
CALL TTALOC
POP PP,2
JRST TTCPY
; GETTERMTABLE(TABLE)
GETTY: CAMN 1,KNIL
JRST GTTY2
CALL CKTRMT
ERROR1 47,TRMTBL
RET
; RETSETERMTABLE(TABLE,orig/TABLE)
RSTTBL: CALL GETTY
EXCH 1,2
CAMN 1,KORIG
JRST .+3
CALL GETTY
CAIA
MOVEI 1,ORGTTY
EXCH 1,2
JRST TTCPY
TTALOC: MOVEI 1,TTYSIZ+2 ;ALLOCATE A TERMINAL TABLE
CALL ALLOC1
MOVEI 2,TTYSIZ+2
HRRM 2,1(1)
RET
TTCPY: PUSH PP,1 ;COPY A TERM TABLE
HRL 1,2
ADD 1,BHC+2
MOVEI 4,TTYSIZ-1(1)
BLT 1,(4)
POP PP,1
CAMN 1,TTYTBL
JRST TTCP2
RET
;TERMTABLEP(TABLE)
TTTBLP: CALL CKTRMT
JRST FALSE
RET
; INREADMACROP()
INRMP: TRNN F,RMFLG ;IS THERE A BLIP?
JRST FALSE ;NO
CALL RLOOK ;FIND READ BLIP
JRST FALSE ;NONE
JUMPE 1,FALSE ;RETURN NIL IF OFF
SUBI 3,3 ;COUND # OF LEVEL THE READ WAS AT
SETZ 1,
SKIPGE @2 ;DONE?
JRST .+3 ;YES
SUBI 3,2 ;NO, STEP TO NEXT
AOJA 1,.-3 ; AND BUMP COUNT
MOVEI 1,ASZ(1)
RET
; SETREADMACROFLG(FLG)
SRMF: CALL RLOOK ;GET READ BLIP
JRST FALSE ;NONE
HRRZ 4,1(VP) ;GET NEW VALUE
CAMN 4,KNIL
SKIPA 4,[0]
SETO 4,
HRRM 4,@2 ;SET READ BLIP NEW VALUE
JUMPE 1,FALSE ;RETURN PREVIOUS VALUE
JRST TRUE
;READ
READX: MOVE 1,KT ;EVALQUOTE READ
HRRZ 2,KT
HRRZ 3,KNIL
READ: TLZ F,NCRFLG
CAME 3,KNIL
TLO F,NCRFLG
CALL IFSET
CALL IRTSET
TRNE F,RMFLG ;READ BLIP?
JRST RD9 ;YES
XREAD: MOVSI 1,-1 ;TOP LEVEL FLAG
JRST XRD1
RD9: TRZ F,RMFLG+RDMFLG ;CLEAR FLAGS
CALL RLOOK ;LOOK FOR READ BLIP
JRST XREAD ;NOT FOUND
SKIPE 1 ;BLIP VALUE 0?
TRO F,RDMFLG ;NO - SET FLAGS
TRO F,RMFLG
JRST XREAD
; SEARCH FOR READ BLIP, SIMILAR TO FNDEVL
RLOOK: MOVE 1,CF
RLOOK5: GETPPI 2,1
MOVEI 3,0(PP)
SUBI 3,0(2)
JUMPE 3,RLOOK2
HRLI 2,3
RLOOK3: HLRZ 4,@2
CAIN 4,READ
JRST RLOOK4
SOJG 3,RLOOK3
RLOOK2: GETCL 1,1
JUMPN 1,RLOOK5
RET
RLOOK4: HRRZ 1,@2
AOS (CP)
RET
;READ TO RIGHT BRACKET
X2READ: CALL X1READ ;READ TO TERMINATOR
XRR: HRRZ 2,FCHAR(FX) ;CHECK TERMINATOR
ADD 2,BSTAB
HLRZ 2,(2)
ANDI 2,JPBITS
CAIN 2,1 ;WAS RIGHT BRACKET?
HLLZS FCHAR(FX) ;YES, CLEAR
RET
;READ TO TERMINATOR
X1READ: MOVEI 1,0
XRD1: PUSH PP,1 ;FLAG,,DOTTED PAIR POINTER
PUSH PP,BHC ;WHOLE LIST,,LAST OF LIST
PUSH CP,XRR1
RD1: CALL RDA ;READ ATOM OR BREAK CHAR
JRST RD5 ;NOT BREAK CHAR
LDB 3,JMPFLD ;JUMP ON BREAK CHAR. TYPE
JRST @RDJTAB(3)
RDJTAB: RDS ;SELF-DELIMITING CHAR.
RDRB ;]
RDLB ;[
RDL ;(
RDR ;)
RDMAC ;ELEMENT READ MACRO
RDMAC ;SPLICE READ MACRO
RDMAC ;INFIX READ MACRO
RDMAC: SKIPN RMONF
JRST RDBQ2 ;NO-READMACROS, JUST A NUMBER
PUSH CP,RDAX ;SAVE I/O ROUTINE ADDRESS
PUSHN 3,3 ;SAVE CURRENT READTABLE
PUSH CP,FX ;PREVIOUS INST. SET US UP FOR 3 NUMBERS
PUSH CP,F
PUSH PP,BSTAB ;SAVE CURRENT READTABLE
PUSH PP,[READ,,1] ;PUT READ BLIP ON STACK
TRO F,RMFLG ;SET BLIP FLAG
TRZ F,RDMFLG ;TURN OFF READMACRO FLAG
HRLM 1,FILEA(FX)
HRRZ 1,@BSTAB
PUSH PP,1
HRRZ 1,FILEA(FX)
PUSH PP,1 ;THE FILE NAME IS 1ST ARG
HRRZ 1,BSTAB ;READTABLS IS 2ND ARG
SUBI 1,RDNUBW+2
PUSH PP,1
MOVEI 1,2
CAIE 3,7 ;IS IT AN INFIX MACRO?
JRST RDMAC2 ;NO
HLRZ 1,-5(PP) ;YES - BUILD A TCONC LIST
SKIPN 1
MOVE 1,KNIL
HRRZ 2,-5(PP)
SKIPN 2
MOVE 2,KNIL
SKIPL -6(PP) ;JUST PASS NIL IF TOPLEVEL READ
CALL CONS
PUSH PP,1
MOVEI 1,3
RDMAC2: CALL EVCC ;CALL THE USER'S FUNCTION
SUB PP,BHC+1 ;REMOVE READ BLIP
POP PP,BSTAB ;RESTORE READTABLE
HLLZ 2,F ;GET LBFFLG AND RASFLG BITS
TLZ 2,-1-LBFFLG-RASFLG
POP CP,F ;GET OLD FLAG BITS
TLZ F,LBFFLG+RASFLG ;PUT IN CURRETN LINBUF AND RASFLG
IOR F,2
POP CP,FX
MOVEM FX,FRX ;ALSO RESET FRX WHO IS USED BY FIN4
POPN 3
POP CP,RDAX ;RESTORE I/O ROUTINE ADDRESS
JRST @RDJMP-5(3)
RDJMP: RDEMAC ;ELEMENT READMACRO
RDSMAC ;SPLICE READMACRO
RDINFX ;INFIX READMACRO
;ELEMENT READMACRO
RDEMAC: SKIPL -1(PP) ;TOP LEVEL?
JRST RD7 ;NO, GO ADDO TO LIST
TRNE F,RDMFLG ;IN A READMACRO?
RET ;YES
HLRZ 2,FILEA(FX) ;NO, IS LASTC()=PEEKC()?
HRRZ 3,FCHAR(FX)
CAIN 2,(3)
JRST XRR ;YES, MIGHT BE A ] THAT NEEDS CLEARING
RET ;NO, EVEN IF PEEK=] IT SHOULD STAY,
; IE, IT'S THERE 'CAUSE OF RDA - 'A]
;SPLICE MACRO
RDSMAC: HRRZ 2,0(PP) ;LCONC RESULT INTO LIST
JUMPE 2,RDSM2 ;WAS NONE
HRLM 1,0(2) ;SMASH IN RESULT
RDSM3: CDRA 1,2 ;GET TAIL
CAMN 1,KNIL ;NULL>
JRST RDSM4 ;YES
LDT 3,1 ;NO - IS IT A LIST
CAIE 3,LISTT
JRST RDSM5 ;NO
MOVEI 2,0(1) ;YES - STEP TO NEXT WORD
JRST RDSM3
RDSM4: HRRM 2,0(PP) ;SAVE THE LAST
JRST RD1 ;AND CONTINUE READING
RDSM2: LDT 3,1 ;NOTHING BUILT YET - RESULT A LIST?
CAIE 3,LISTT
JRST RD1 ;NO
HRLM 1,0(PP) ;YES - SET UP WHOLE LIST
MOVEI 2,0(1)
JRST RDSM3 ;AND GO FIND THE TAIL
RDSM5: HRRM 2,-1(PP) ;MAKE IT LOOK LIKE IT WAS READ
MOVE 2,KNIL
CALL CONS
HRRM 1,0(PP) ;THIS IS THE NEW TAIL
MOVEI 2,0(1)
MOVE 1,KPER
CALL CONS
HRRZ 2,-1(PP)
HRLM 1,(2) ;ATTACH IT INTO TAIL
JRST RD1 ;AND CONTINUE READING
;INFIX MACRO
RDINFX: SETZM 0(PP)
LDT 2,1 ;IS RESULT A LIST?
CAIE 2,LISTT
JRST RD1 ;NO - EMPTY TCONC PAIR, IGNORE
CDRA 2,1 ;YES - THIS BECOMES NEW LIST
SETZM 0(PP)
CAMN 2,KNIL ;RESULT A NIL LIST?
JRST RD1 ;YES
HRRM 2,0(PP)
CARA 2,1
HRLM 2,0(PP)
SKIPL -1(PP) ;TOP LEVEL?
JRST RD1 ;NO - KEEP READING
HLRZ 1,0(1) ;YES
CAIN 1,(2) ;1 ELEMENT LIST?
HRRZ 1,0(1) ;YES, RET THE 1 ITEM, THIS IS PROBABLY
; WHAT THE USER INTENDED
RET
RDBQ2: HRLM 1,FILEA(FX) ;SAVE LAST CHAR
CALL PAC ;SELF-DELIMITING CHARACTER
CALL MKATM ;CONVERT TO ATOM
RD2: SKIPGE -1(PP) ;TOP LEVEL?
RET ;YES, RETURN SINGLE S-EXP
RD7: MOVE 2,KNIL ;NO, NCONC TO ACCUMULATED LIST
CALL CONS
HRRZ 2,0(PP) ;LAST OF LIST
JUMPE 2,RD4 ;WAS NONE
HRLM 1,0(2) ;RPLACD LAST WITH NEW
HRRM 1,0(PP) ;UPDATE LAST
JRST RD1
RD4: HRRZM 1,0(PP) ;SETUP WHOLE AND LAST
HRLM 1,0(PP)
JRST RD1
XRR1: XWD 0,.+1
SUB PP,BHC+2 ;FLUSH TEMPS
RET
;[
RDLB: CALL X2READ
JRST RD2
;(
RDL: CALL X1READ
SKIPL -1(PP) ;TOP LEVEL?
JRST RD7 ;NO, GO ADD TO LIST
TRNN F,RDMFLG ;YES - IN A READMACRO?
JRST XRR ;NO, RETURN
RET ;YES - JUST RETURN THE VALUE
;]
RDRB: SKIPL -1(PP) ;TOP LEVEL?
HRRM 1,FCHAR(FX) ;NO, SETUP TO REPROCESS SAME CHAR
;)
RDR: HRLM 1,FILEA(FX) ;SAVE LAST CHAR
SKIPGE -1(PP) ;TOP LEVEL?
TRNN F,RDMFLG ;YES - IN A READMACRO?
JRST RDR2 ;NO
HRRM 1,FCHAR(FX) ;YES - BACKUP CHAR INCASE USER HAS
;... A NLSETQ. WE WILL THEN WANT TO
;... BE ABLE TO GET IT AT A HIGHER LEVEL
ERROR0 45,R ;ERROR, TRIED TO READ ) OR ]
RDR2: HRRZ 2,-1(PP) ;PERIOD ENCOUNTERED BEFORE?
JUMPN 2,RDP1 ;YES
RDP2: HLRZ 1,0(PP) ;NO, GET WHOLE LIST
JUMPG 1,.+2 ;WAS NULL?
MOVE 1,KNIL ;YES, RETURN NIL
RET
RDS: MOVE 3,@BSTAB
TLNN 3,STRBIT ;IS IT A "?
JRST RDBQ2 ;NO - SELF DELIMITING CHAR.
CALL RDSTR
JRST RD2
;ATOM
RD5: CAMN 1,KPER ;WAS PERIOD?
TRNE F,RQTFLG ;AND NOT QUOTED?
JRST RD2 ;NO, ORDINARY ATOM
HRRZ 2,0(PP) ;YES, SAVE CURRENT LAST
HRRM 2,-1(PP)
JRST RD2
;FINISH DOTTED PAIR
RDP1: CDRA 3,2 ;IS CDDR OF PREVIOUS LAST
CDRA 3,3 ;EQ TO CURRENT LAST?
HRRZ 1,0(PP)
CAIE 1,0(3)
JRST RDP2 ;NO, TREAT DOT AS ORDINARY ATOM
CARA 1,1 ;YES, PUT SECOND HALF IN PROPER PLACE
HRLM 1,0(2)
JRST RDP2
;READ STRING
RSTRNG: CALL IFSET
CALL IRTSET
TRZ F,LREAD ;USER ENTRY, QUITS ON BRK. OR SEP.
TROA F,RATFLG
RDSTR: TRO F,LREAD
CALL MKSTRS ;SET UP TO STORE
RDSTR2: CALL GCHIN
MOVE 2,@BSTAB
SKIPE ESCONF ;ESCAPES ON
TLNN 2,ESCBIT ;AND IS THIS AN ESCAPE?
JRST RDSTR3
TRO F,RQTFLG
CALL GCHIN
JRST RDSTR1
RDSTR3: TRNN F,LREAD
JRST RDSTR7
TLNE 2,STRBIT ;DOUBLE-QUOTE?
JRST RDSTS2
RDSTR1: CALL MKSTR1 ;STORE CHAR
JRST RDSTR2
RDSTR4:RDSTR7: TLNE 2,BRKBIT ;CHECK FOR BRK OR SEPR
JRST RDSTS1
TLNE 2,SEPBIT
JRST RDSTS
JRST RDSTR1
RDSTS: TRO F,SEPFLG
RDSTS1: HRRM 1,FCHAR(FX)
LDB 1,FREEST
RDSTS2: HRLM 1,FILEA(FX)
MOVE 1,UNP1
JRST MKSP
;RATOM - USED BY READ AND AS FUNCTION
RATOM: CALL IFSET ;USER ENTRY
CALL IRTSET
TRZ F,LREAD
TROA F,RATFLG
RDA: TRO F,LREAD ;LISP READ ENTRY
RAT: TRZ F,CHFLG+RQTFLG+SEPFLG
CALL PACS ;INITIALIZE ATOM PACK
RAT1: CALL GCHIN
MOVE 2,@BSTAB
SKIPE ESCONF
TLNN 2,ESCBIT
JRST RAT3 ;ESCAPE OFF OR NOT ESCAPE
TRO F,RQTFLG
CALL GCHIN
JRST RAT4
RAT3: TRNN F,CHFLG ;HAVE A CH YET?
TLNN 2,FRSTBT ;NO, ACT LIKE BRK IF ITS A "FIRST" RM
TLNE 2,BRKBIT
JRST RATB
TLNE 2,SEPBIT
JRST RATS
RAT4: CALL PAC
TRO F,CHFLG
JRST RAT1
RATB: TRNE F,CHFLG
JRST RAT2
TRNE F,LREAD
JRST RSKP ;SKIP ON BREAK FOR LISP READ
RAT7: HRLM 1,FILEA(FX)
RAT6: CALL PAC
JRST MKATM1
RAT2: HRRM 1,FCHAR(FX)
LDB 1,CBUFP
HRLM 1,FILEA(FX)
JRST MKATM1
RATS: TRNE F,CHFLG
JRST RAT2
TRO F,SEPFLG ;FOR WT, SEPARATOR PRECEEDS ATOM
JRST RAT1
READC: CALL IFSET ;USER READC, NO SECOND ARG
CALL PACS
TRZ F,LREAD+RATFLG
CALL GCHIN
JRST RAT7
;CONTROL - MISCELLANEOUS MODES FOR TTY INPUT
CONTRL: EXCH 1,2
CALL GETTY ;GET TERM TABLE
EXCH 1,2
SETZ 3,
SETO 4,
CAMN 1,KNIL
JRST CNTRLN
CAME 1,KT
RET
EXCH 4,LBFLGW(2) ;TURN OFF LINE BUFFER
SKIPN 4
HRRZ 1,KNIL
JRST CNTRL2
CNTRLN: EXCH 3,LBFLGW(2) ;SET TO LINE BUFFER
SKIPE 3
HRRZ 1,KT
CNTRL2:
CAME 2,TTYTBL ;CURRENT TABLE?
JRST CNTRL1 ;NO
PUSH PP,1
CALL SETMOD ;SETS MODE ACCORDING TO LBFFLG
POP PP,1
CNTRL1: RET
;ECHOMODE - SETS THE ECHO OF TTY INPUT
ECHMOD: EXCH 1,2
CALL GETTY
EXCH 1,2
MOVE 3,ECHMDW(2)
CAME 1,KNIL
JRST ECHMD1
SETZM ECHMDW(2)
SKIPE 3
MOVE 1,KT
JRST CNTRL2
ECHMD1: SETOM ECHMDW(2)
SKIPN 3
MOVE 1,KNIL
JRST CNTRL2
;MISCELLANEOUS TESTS OF LAST ATOM READ
RATEST: CAMN 1,KNIL
JRST RATT1
CAMN 1,KT
JRST RATT2 ;T- CHECK FOR SEPARATOR
CAIN 1,ASZ+1 ;1- CHECK FOR DOUBLE QUOTE
TRNN F,RQTFLG
JRST FALSE
JRST TRUE
RATT1: TRNE F,CHFLG
JRST FALSE
JRST TRUE ;LAST ATOM WAS BREAK CHAR
RATT2: TRNN F,SEPFLG
JRST FALSE
JRST TRUE ;LAST ATOM PRECEEDED BY SEPARATOR
RAISE: EXCH 1,2 ;GET TERM TABLE
CALL GETTY
HRREI 3,-1 ;DECODE ARG
CAMN 2,KNIL
JRST .+4
CAMN 2,KT
ADDI 3,1
ADDI 3,1
EXCH 3,RASMOD(1) ;SET MODE AND GET PREV.
MOVE 2,KNIL ;CONVERT VAL TO RETURNABLE FORM
JUMPL 3,.+4
SKIPE 3
SKIPA 2,KT
MOVEI 2,ASZ
PUSH PP,2
CAMN 1,TTYTBL ;CHANGING CURRENT TABLE?
CALL SETMOD ;YES
POP PP,1
RET
;PEEK AT NEXT CHARACTER
PEEKC: CALL IFSET
CALL IRTSET
CALL PACS
TRZ F,LREAD+RATFLG
HRRZ 1,FCHAR(FX) ;ANY SAVED CHAR?
JUMPN 1,RAT6 ;YES - USE IT
JUMPE FX,PEEKCT ;HANDLE TTY SPECIAL
PEEKC3: CALL GCHIN ;NO - GET A CHAR
HRRM 1,FCHAR(FX) ;SAVE IT
JRST RAT6 ;AND RETURN IT
IFE TEN50,<
PEEKCT: SKIPG LNBFC ;ANYTHING IN LINEBUFFER
JRST PEEKC2
MOVE 2,LNBFP ;YES - GET IT
ILDB 1,2
JRST PEEKC5
PEEKC2: HRRZ 1,-1(PP)
CAME 1,KNIL
JRST PEEKC4
MOVEI 1,100 ;WAKEUP ON EVERYTHING
RFMOD
MOVEM 2,OLDMOD
TRO 2,10000
SFMOD
MOVE 2,CHPOS(FX)
CALL FIN1 ;GET CHAR FROM SYSTEM
MOVEM 2,CHPOS(FX) ;UNDO CHAR ACCOUNTING
MOVEI 4,0(1)
MOVEI 1,100 ;RESET WAKEUP
MOVE 2,OLDMOD
SFMOD
HRRZ 1,FILEN(FX)
BKJFN ;BACK UP
ERROR0 20,RESET ;??? WHAT DOES BAD RETURN MEAN
MOVEI 1,0(4)
PEEKC5: TLNN F,RASFLG ;RAISE MODE?
JRST RAT6 ;NO
CAIL 1,"a" ;IS IT A LOWER CASE LETTER
CAILE 1,"z"
JRST RAT6 ;NO
TRZ 1,40 ;YES - MAKE UPPER CASE
JRST RAT6
PEEKC4: TRO F,LREAD
JRST PEEKC3
>
LASTC: CALL IFSET
CALL PACS
HLRZ 1,FILEA(FX)
CALL PAC
JRST MKATM
;GET CHARACTER FROM CURRENT INPUT FILE
GCHIN: HRRZ 1,FCHAR(FX) ;ANY SAVED CHAR?
JUMPE 1,@RDAX ;NO, GO GET INPUT
HLLZS FCHAR(FX)
RET
GCHIT: SOSGE LNBFC ;TELETYPE - CHARS LEFT IN BUFFER?
CALL GCHIA ;NO, GO FILL IT
GCHI1: ILDB 1,LNBFP ;YES, GET NEXT ONE
TLNN F,RASFLG ;INTERNAL RAISE?
RET ;NO
CAIL 1,"a" ;YES - LOWER CASE LETTER?
CAILE 1,"z"
RET ;NO
TRZ 1,40 ;YES, MAKE UPPER CASE
RET
;FILL TTY LINE BUFFER, PERFORMING EDITING
GCHIB: TRO F,LREAD
TLOA F,BKFLG ;ENTRY TO FILL FROM STRING
GCHIA: TLZ F,BKFLG ;NORMAL ENTRY
GCHI2: SETZM LNBFC ;COUNT
TRNE F,LREAD+RATFLG ;LISP READ OR RATOM ?
JRST GCHI7 ;YES
TLNN F,LBFFLG
JRST GCHI7
AOS 0(CP) ;SO THAT WE DO INTERNAL RAISE
CALL FIN1 ;UN LINE BUFFERED READC, GET CHAR
SKIPN 3,DRIBFX ;DRIBBLING?
RET ;NO
HRRZ 2,TTYTBL ;ECHOING INPUT?
SKIPN ECHMDW(2)
RET ;NO
EXCH 3,FX ;DRIBBLE THE CHAR
CALL FOUT
EXCH 3,FX
RET
GCHI7: PUSH CP,PARENC
PUSH CP,BRKCT
PUSH CP,F ;SAVE VALUES FOR POSSIBLE LINE DELETE
MOVE 7,[POINT 7,LNBF,-1] ;INITIAL POINTER
MOVEM 7,LNBFP
JRST GCHI4
FIXCTA: MOVEI 1,100 ;TURN OFF ↑A MODE
MOVE 2,INCTLA ;BY RESETING TTY MODE
SFMOD
SETZM INCTLA
RET
GCHI5: AOS LNBFC ;COUNT CHARACTER JUST ADDED
GCHI4: TLNE F,BKFLG
JRST GCHIB1
CALL FIN1 ;GET NEXT CHAR FROM TTY
GCHIB2: IDPB 1,7 ;PUT INTO BUFFER
HRRZ 2,TTYTBL ;SEE IF A SPECIAL FORMAT CHARACTER
CAMN 1,CTLQ(2)
JRST GCHQ ;↑Q
CAMN 1,CTLR(2)
JRST GCHR ;↑R
CAMN 1,CTLA(2)
JRST GCHA ;↑A
SKIPN INCTLA ;IN A ↑A LOOP?
JRST GCHIB7 ;NO
PUSH PP,1 ;YES
HRRZ 1,TTYTBL
HRROI 1,CAMSGP(1) ;PRINT THE POST MESSAGE
CALL GCHMSG
CALL FIXCTA ;LEAVE ↑A MODE
POP PP,1
HRRZ 2,TTYTBL
SKIPE ECHMDW(2) ;ECHOING INPUT?
CALL TCO1 ;YES - ECHO THE CHAR
HRRZ 2,TTYTBL
SETZM INCTLA ;NO LONGER IN ↑A MODE
GCHIB7: CAMN 1,CTLV(2)
JRST GCHV ;↑V
CAMN 1,CTLEOL(2)
JRST GCHE ;EOL
GCHI3A: CAMN 7,[POINT 7,LNBF+LLNBF-1,34]
JRST GCHE ;FULL , ACT LIKE EOL
JRST GCHLC ;NOT SPECIAL, CHECK LISP FORMATTERS
GCHIB1: CALL BKCHAR ;GET CHAR FROM STRING
JRST GCHE1 ;NO MORE - QUIT
IDPB 1,7
JRST GCHLC ;ASSUME CANT GET SPECIAL CHARS HERE
GCHE1: SUB CP,BHC+3
RET
GCHE: SUB CP,BHC+3
GCHE2: SKIPN 3,DRIBFX ;DRIBBLING?
RET ;NO
HRRZ 2,TTYTBL ;ECHOING?
SKIPN ECHMDW(2)
RET ;NO
MOVE FX,3 ;SET UP TO OUTPUT LINE
MOVE 3,LNBFP ;GET THE BYTE POINTER
GCHE0: ILDB 1,3
CALL FOUT ;DRIBBLE A CHARACTER
CAME 3,7 ;DONE?
JRST GCHE0 ;NO
MOVE FX,FRX ;YES
RET
GCHQ: SKIPE INCTLA
CALL FIXCTA
HRRZ 2,TTYTBL
HRROI 1,CTQMSG(2)
GCHA1A: CALL GCHMSG
POP CP,F
POP CP,BRKCT ;RESTORE VALUES TO BEG OF LINE
POP CP,PARENC
JRST GCHI2
GCHA: HRRZ 2,TTYTBL
SOSGE LNBFC ;CHARACTERS TO DELETE?
JRST GCHA1 ;NO
SKIPN INCTLA ;1ST ↑A?
JRST GCHA2 ;YES
HRROI 1,CAMSG2(2) ;NO - USE OTHER MESSAGE
GCHA3: CALL GCHMSG
IBP 7 ;BACKUP POINTER 2
IBP 7
IBP 7
SOS 3,7 ;LEAVING NEW VALUE IN AC2 ALSO
ILDB 1,3 ;CHARACTER TO BE DELETED
SKIPN ECHFLG(2) ;ECHOING DELETED CHAR
SKIPN ECHMDW(2) ;... AND TYPEIN?
CAIA ;NO
CALL TCO1 ;TYPE IT OUT
JRST GCHDC ;CHECK FOR LISP FORMATTERS
GCHA2: MOVEI 1,100 ;ENTER ↑A MODE
RFMOD
MOVEM 2,INCTLA
TRZ 2,6000 ;TURN OFF ECHO
TRO 2,170000 ;WAKE UP ON EVERYTHING
SFMOD
HRRZ 2,TTYTBL
HRROI 1,CAMSG1(2) ;FIRST ↑A MESSAGE
JRST GCHA3
GCHA1: HRROI 1,CAMSGE(2) ;PRINT EMPTY BUFFER MESSAGE
JRST GCHA1A
GCHR: SKIPE INCTLA ;CLEAR ↑A MODE
CALL FIXCTA
MOVEI 1,EOL ;RETYPE LINE, EOL FIRST
CALL TCO1
ADD 7,[7B5] ;BACKUP POINTER 1 TO FLUSH R
MOVE 6,LNBFP ;INITIAL POINTER
MOVE 5,LNBFC ;CURRENT COUNT
GCHR1: JUMPE 5,GCHI4 ;DONE
ILDB 1,6
CALL TCO1
SOJA 5,GCHR1
GCHV: CALL CTRLV ;GET CHAR UNDER THE ↑V
DPB 1,7 ;STORE ON TOP OF CTRLV
JRST GCHI5
CLRTTY: SETZM LNBFC
SETZM PARENC
SETZM BRKCT
HLLZS FCHAR ;CLEAR SINGLE CHARACTER BUFFER
TRZ F,GCHDQF
RET
GCHMSG: PUSH CP,2 ;FAST OUTPUT TO TTY
PSOUT
MOVEI 1,101 ;NOW GET THE LINE POSITION
RFPOS ;WILL BE CORRECT EVEN IF THINGS
HRRZM 2,CHPOS+1 ;... LIKE ↑H ARE BACKSPACING
POP CP,2
RET
TCO1: MOVEI FX,1 ;OUTPUT TO TTY: WITHOUT DRIBBLING
CALL CHACCT
MOVE FX,FRX
PBOUT
RET
U DRIBFX ;CONTAINS THE INDEX OF THE DRIBBLE FILE
U PARENC
U BRKCT
U LNBFP
U LNBFC
LLNBF==40
U LNBF,LLNBF
U SLNBF,LLNBF ;BUFFER FOR SAVED LINE BUFFER
U INCTLA ;IN ↑A MODE FLAG
U RDAX
;SPECIAL LINE EDITING FOR LISP FORMAT CHARACTERS
GCHLC: TRNN F,LREAD+RATFLG
JRST GCHI5 ;NOT LISP READ OR RATOM
MOVE 2,@BSTAB
SKIPN ESCONF
JRST .+3
TLNE 2,ESCBIT
JRST GCHESC
TRNN F,LREAD
JRST GCHL1
TLNE 2,STRBIT ;DOUBLE QUOTE?
JRST GCHDQ
TRNE F,GCHDQF ;INSIDE DOUBLEQUOTE NOW?
JRST GCHI5 ;YES
TLNE 2,IMEDBT ;IS IT AN "IMEDIATE" READMACRO?
JRST GCHE ;YES, ACT LIKE EOL
LDB 2,JMPFLD
JRST @GCHJMP(2)
GCHJMP: GCHL3
GCHRBK ;]
GCHLBK ;[
GCHLPR ;(
GCHRPR ;)
GCHL3
GCHL3
GCHL3
GCHL3: TLNN F,LBFFLG ;LINE-BUFFERRED?
JRST GCHI5 ;YES - GO ON
SKIPN BRKCT ; NO - CHECK BRACKET AND PAREN COUNTS
SKIPE PARENC
JRST GCHI5 ;INSIDE LIST - GO ON
JRST GCHL2 ;GO CHECK FOR BREAK AND SEPR
GCHLPR: SKIPN BRKCT
AOS PARENC
JRST GCHI5
GCHRBK: SOSLE 1,BRKCT
JRST GCHI5
JUMPL 1,GCHACR ;UNMATCHED RIGHT BRACKET
SKIPLE PARENC
JRST GCHI5
GCHRPR: SKIPN BRKCT
SOSLE PARENC ;COUNT DOWN PARENS
JRST GCHI5
GCHACR: SETZM PARENC ;TERMINATOR
SETZM BRKCT
TLNE F,NCRFLG
JRST GCHE
CALL GCHE2 ;MAKE SURE BUF IS DRIBBLED FIRST
TMSG EOLM ;NOW DO THE EOL
JRST GCHE1
GCHLBK: AOS BRKCT
JRST GCHI5
GCHDQ: TRCE F,GCHDQF
JRST GCHL3 ;CLOSING QUOTE, CHECK IF WANT TO QUIT
JRST GCHI5
GCHESC: AOS LNBFC ;ESCAPE COMING ON, QUOTE ONE CHAR
TLNE F,BKFLG
CALL BKCHAR ;GET CHAR FROM STRING -IF EMPTY,READ
CALL FIN1
HRRZ 2,TTYTBL
CAMN 1,CTLV(2) ;CONTROL-V?
CALL CTRLV
GCHES1: IDPB 1,7
JRST GCHI5
GCHL1: TLNN F,LBFFLG ;HERE IF RATOM
JRST GCHI5 ;LIN BUFFERRED, GO TO EOL
GCHL2: MOVE 2,@BSTAB ;NOT LINE BUFFERED, BRK OR SEPR?
TLNE 2,BRKBIT+SEPBIT
JRST GCHE ;YES, QUIT
JRST GCHI5 ;YES
CTRLV: TLNE F,BKFLG ;READING FROM STRING?
RET ;YES-PASS ↑V THRU
CALL FIN1 ;GET ANOTHER CHAR
CAIG 1,"z"
CAIN 1,100
RET ;IGNORE @
CAIL 1,"a"
TRZ 1,40 ;UPPER SHIFT
CAIGE 1,133
ANDI 1,77 ;TRANSFORM A-Z TO ↑A-↑Z
RET ;ALL ELSE UNCHANGED
;ACCOUNT FOR DELETED CHARACTER
GCHDC: SKIPLE 4,LNBFC ;ANYTHING IN BUFFER?
SKIPN ESCONF
JRST GCHDC1
TRZ F,ESCFLG
GCHDC3: UBP 3 ;BACK UP POINTER
LDB 5,3 ;...LOOK FOR ODD OR EVEN ESC
EXCH 1,5
MOVE 1,@BSTAB
EXCH 1,5
TLNN 5,ESCBIT
JRST GCHDC2
TRC F,ESCFLG
SOJG 4,GCHDC3
GCHDC2: TRZN F,ESCFLG
JRST GCHDC1
IBP 7 ;CHAR IS UNDER ESC. DELETE ESC. ALSO
JRST GCHA
GCHDC1: TRNN F,LREAD
JRST GCHI4
MOVE 2,@BSTAB
TLNE 2,STRBIT
TRC F,GCHDQF
TRNE F,GCHDQF
JRST GCHI4 ;WITHIN DOUBLEQUOTE
LDB 2,JMPFLD
XCT GCHDC4(2)
GCHDC4: JRST GCHI4
AOS BRKCT ;]
SOS BRKCT ;[
JRST GCHDC5 ;(
JRST GCHDC6 ;)
JRST GCHI4
JRST GCHI4
JRST GCHI4
GCHDC5: SKIPN BRKCT ;NO COUNTING INSIDE BRACKETS
SOS PARENC
JRST GCHI4
GCHDC6: SKIPN BRKCT
AOS PARENC
JRST GCHI4
;INITIALIZE ATOM PACKER
PACS: PUSH CP,1
SETZM POCT
SETZM PDEC
TRZ F,NEGFLG+LETFLG+QFLG+DIGFLG+FLTFLG
PACS2: MOVN 1,MAXATL
MOVEM 1,NICHRS
ADDI 1,4
IDIVI 1,5
ADD 1,ENDPN
CAML 1,FREEPN
JRST PACS1
MOVEI 1,PNAMT
PUSHJ GP,GC1 ;RECLAIM
HRRZ 1,TYPBLK+PNAMT
HRRZ 1,TNFR(1)
IMULI 1,5
CAIL 1,NATMC ;ENUF NOW?
MOVEI 1,NATMC ;YES - RESET MAXATL TO ORIG. VALUE
MOVEM 1,MAXATL ;NO - MAKE MAXATL SHORTER
CAIL 1,NATMC
JRST PACS2
JRST RESET ; AND GO TO TOP
PACS1: MOVE 1,FREEPN
HRLI 1,350700
MOVEM 1,CBUFP
MOVEM 1,SCBUFP
POP CP,1
RET
U POCT ;ACCUMULATES OCTAL NUMBER
U PDEC ;ACCUMULATES DECIMAL NUMBER
U CBUFP ;CURRENT POINTER TO PACKED STRING
U SCBUFP ;INITIAL POINTER TO PACKED STRING
U NICHRS ;COUNT OF CHARACTERS IN ATOM
;ACCUMULATE CHARACTER FOR ATOM
PAC: IDPB 1,CBUFP
TRNE F,LETFLG+QFLG
JRST PACL
CAIN 1,"E"
TRNN F,DIGFLG
CAIN 1,"."
JRST PACFI
CAIN 1,"-"
JRST PACM
CAIN 1,"+"
JRST PACP
CAIN 1,"Q"
JRST PACQ
CAIL 1,"0"
CAILE 1,"9"
JRST PACL
TRO F,DIGFLG
SUBI 1,"0"
MOVE 2,POCT
LSH 2,3
IORI 2,0(1)
MOVEM 2,POCT
MOVE 2,PDEC
LSH 2,2
ADDB 2,PDEC ;TIMES 5
ADDM 2,PDEC ;TIMES 10
ADDM 1,PDEC
JRST PACOUT
PACQ: TRNE F,FLTFLG
JRST PACL
TROA F,QFLG
PACFI: TRO F,FLTFLG
JRST PACOUT
PACM: TRO F,NEGFLG
PACP: TRNN F,FLTFLG
TRNN F,DIGFLG
JRST PACOUT
PACL: TRO F,LETFLG
PACOUT: AOSL NICHRS
ERROR0 13,RESET ;ATOM TOO LONG
RET
;MAKE ATOM
MKATM: TRZ F,LREAD ;MAKE SURE LISP READ IS OFF FOR MKAC
MKATM1: TRNN F,LETFLG ;READ AND RATOM ENTRY
TRNN F,DIGFLG
JRST MKAC ;>0 LETTERS OR 0 DIGITS => LITERAL ATOM
TRNE F,FLTFLG ;FLOATING NUMBER?
JRST MKFLT ;YES
MOVE 1,PDEC
TRNE F,QFLG ;OCTAL NUMBER
MOVE 1,POCT ;YES
TRNE F,NEGFLG ;MINUS SIGN?
MOVN 1,1 ;YES, NEGATE
JRST MKN
MKAC: MOVE 1,MAXATL
ADDB 1,NICHRS
CAIE 1,1 ;ONE-CHARACTER ATOM?
JRST MKAL ;NO
TRNE F,LREAD ;YES, IN LISP READ
TRNE F,RQTFLG ; AND NOT QUOTED?
JRST MKAL ;NO
HLRZ 1,FILEA(FX) ;YES, GET THE 1 CHAR.
MOVE 2,@BSTAB
TLNE 2,ALONBT ;IS IT AN "ALONE" READMACRO?
JRST RSKP ;YES, ACT LIKE RATOM HAD A BRK CHAR.
MOVEI 1,1 ;NO, RESTORE COUNT
JRST MKAL ; AND MAKE THE ATOM
;TRANSFORM CHARACTER STRING INTO FLOATING NUMBER
MKFLT: IFE TEN50,<SETZ 1,
IDPB 1,CBUFP
MOVE 1,SCBUFP
FLIN
JRST MKAC
CAME 1,CBUFP
JRST MKAC ;DIDNT USE ALL CHARS
MOVE 1,2
JRST MKFN
>
IFN TEN50,<MOVE 3,SCBUFP
SETZ 4,
CALL MKFI ;GET INTEGER PART
TRNE F,NEGFLG
MOVN 1,1
MOVE 5,2 ;SAVE TERMINATING CHARACTER
CALL FXFLT ;FLOAT INTEGER
MOVE 4,1
CAIE 5,"." ;IS THERE A FRACTION?
JRST MKFE ;NO- GO DO EXPONENT
MOVE 5,FT01 ;0.1
TRNE F,NEGFLG
MOVNS 5
MKFL1: CAMN 3,CBUFP
JRST MKFLX
ILDB 2,3
CAIN 2,"E"
JRST MKFE
CAIG 2,"9"
CAIGE 2,"0"
JRST MKAC ;REALLY ISNT FLOATING NUM, ATOM
SUBI 2,"0"
MOVSI 2,211000(2) ;FLOAT THE DIGIT
FMPR 2,5
FADR 4,2
FMPR 5,FT01 ;0.1
JRST MKFL1
MKFE: CALL MKFI ;GET EXPONENT
MOVEI 5,FT
TRNE F,NEGFLG
MOVEI 5,FT0
MKFE1: SUBI 5,1
TRNE 1,1
FMPR 4,0(5)
LSH 1,-1
JUMPN 1,MKFE1
MKFLX: MOVE 1,4
JRST MKFN ;BOX IT
MKFI: TRZ F,NEGFLG ;GET INTEGER WITH OPTIONAL SIGN
SETZ 1,
ILDB 2,3
CAIN 2,"-"
TROA F,NEGFLG
CAIN 2,"+"
JRST MKFI2
MKFI1: CAIG 2,"9"
CAIGE 2,"0"
RET ;QUIT ON NON NUMBER
SUBI 2,"0"
IMULI 1,12
ADDI 1,0(2)
MKFI2: CAMN 3,CBUFP
RET ;QUIT ON END BUFFER
ILDB 2,3
JRST MKFI1
>
;CONSTRUCT LITERAL ATOM
MKAL: DPB 1,SCBUFP ;STORE CHAR COUNT AT BEG OF STRING
IDIVI 1,5
MOVE 2,[774000000000
777760000000
777777700000
777777777400
777777777776](2)
ANDM 2,@CBUFP ;CLEAR OUT TRAILING CHARS
HRRZ 1,SCBUFP ;PNAME ADDRESS
CALL HENTER ;LOOKUP NAME IN ATOM HASH TABLE
JRST MKAL1 ;ALREADY PRESENT
MOVEI 7,0(1) ;NEW ENTRY, H.T. ADDRESS IN 1
MKALG1: MOVE 1,FREEAT ;ATOM FREE LIST
JUMPE 1,MKALGC ;NO ATOMS LEFT
MOVE 1,0(1) ;GET NEXT ENTRY IN LIST
EXCH 1,FREEAT ;UPDATE FREE LIST POINTER
MOVE 2,KNOB ;SETUP TOP LEVEL CELLS
HRL 2,KNIL ;NOBIND=>CAR, NIL=>CDR
MOVEM 2,0(1)
HRRI 2,(EXCAL)
MOVSM 2,1(1)
HRLZ 2,SCBUFP ;PNAME POINTER
MOVEM 2,2(1)
AOS 2,CBUFP ;UPDATE PNAME POINTER
HRRZM 2,FREEPN
MOVEI 2,2(1) ;POINTER TO PNAME CELL
HRRM 2,0(7) ;=>HASH TABLE
RET
MKAL1: HRRZ 1,0(1) ;GET POINTER TO ATOM
MOVEI 1,-2(1) ;MAKE IT POINT TO VALUE, NOT PNAM CELL
RET
MKALGC: CALL ATOMGC ;COLLECT ATOMS
JRST MKALG1
EVALUU: EXCAL 0
;PRINT, ETC.
PRINTX: MOVE 2,KT ;PRINT TO TTY
HRRZ 3,KT
PRINT: CALL PRIN2
TCH EOL
RET
PRIN1: TRO F,PMCFLG ;ENABLE MARGIN CHECKING
CALL OFSET
PRIN1A: TLZ F,PDQFLG ;DISABLE ESCAPE
TLO F,PRXFLG ;ENABLE RADIX
JRST IPRE1
PRIN2: TRO F,PMCFLG ;ENABLE MARGIN CHECKING
JRST PRINN
PRIN3: TRZ F,PMCFLG ;DISABLE MARGIN CHECKING
CALL OFSET
PUSHN CHPOS(FX)
CALL PRIN1A
POPN CHPOS(FX)
RET
PRIN4: TRZ F,PMCFLG ;ENABLE MARGIN CHECKING
PUSH PP,3
CALL OFSET
POP PP,3
PUSHN CHPOS(FX)
CALL PRIN2A
POPN CHPOS(FX)
RET
IPRE: TLZ F,PDQFLG+PRXFLG ;DISABLE ESCAPE AND RADIX
HRRZ 3,@KPRXFL ;IF PRXFLG=T - ENABLE RADIX
CAME 3,KNIL
TLO F,PRXFLG
JRST IPRE3
IPRE2: TLO F,PDQFLG+PRXFLG ;INTERNAL PRINT, PRIN2 FORMAT
MOVEM 2,PREX ;INTERNAL SUBR
MOVNI FX,1 ;DENOTES NO FILE
JRST IPRE4
IPRE3: MOVEM 2,PREX ;INTERNAL SUBR
MOVNI FX,1 ;DENOTES NO FILE
JRST IPRE1
PRINN: PUSH PP,3
CALL OFSET
POP PP,3
PRIN2A: TLO F,PDQFLG+PRXFLG
IPRE4: CALL ORTSET
IPRE1: MOVE 2,PPLVL
MOVEM 2,TPLVL
SETZM PLVL
TLZ F,PRPFLG
PRE: PUSH PP,1
STE 1,LIST
JRST PRE5
HRLM 1,0(PP)
CAIE FX,1 ;OUTPUT TTY?
JRST PRE6 ;NO, DONT CHECK PRINTLEVEL
MOVE 1,TPLVL
CAMG 1,PLVL
JRST PRE4
TLNE F,NEGPLF
TLZN F,PRPFLG
JRST PRE6
TCH EOL
PRE6: TCH "("
AOS PLVL
PRE1: HLRZ 1,0(PP)
STE 1,LIST
JRST PRE2
CDRA 2,1
CARA 1,1
HRLM 2,0(PP)
CALL PRE
HLRZ 1,0(PP)
CAMN 1,KNIL
JRST PRE3
CALL SPACE1
CAIE FX,1 ;OUTPUT TTY?
JRST PRE1 ;NO, DONT CHECK PRINTLEVEL
MOVE 1,TPLVL
CAML 1,PLVL
JRST PRE1
TCH "-"
TCH "-"
PRE3: TLO F,PRPFLG
TCH ")"
SOS PLVL
PREE: POP PP,1
HRRZ 1,1
RET
PRE2: TCH "."
CALL SPACE1
CALL PRATM
JRST PRE3
PRE4: TCH "&"
JRST PREE
PRE5: TLZ F,PRPFLG
CALL PRATM
JRST PREE
TCHQ: PUSH CP,1 ;TYPE ONE QUOTED CHARACTER UUO
HRRZ 1,40
CALL PREC
POP CP,1
RET
U PPLVL ;PERMANENT PRINT LEVEL
U TPLVL ;TEMPORARY (THIS PRINT) PRINT LEVEL
U PLVL ;RUNNING PRINT LEVEL
SPACE1: PUSH CP,1
JUMPL FX,SPA2 ;REAL FILE?
TRNN F,PMCFLG ;CHECK MARGIN?
JRST SPA2 ;NO
HRRZ 1,CHPOS(FX)
ADDI 1,10 ;WITHIN 10 OF MARGIN?
CAMLE 1,LINSIZ
TCH EOL ;YES, CR
CAMG 1,LINSIZ
SPA2: TCH " " ;NO, SPACE
POP CP,1
RET
SPACES: CALL OFSET
CALL IUNBOX
MOVE FX,FPX
HRRZ 2,CHPOS(FX)
ADD 2,1
CAMLE 2,LINSIZ ;WILL PASS MARGIN?
TCH EOL ;YES, NEW LINE FIRST
JUMPLE 1,FALSE ;NO, OUTPUT AND COUNT SPACES
TCH " "
SOJG 1,.-1
JRST FALSE
SPA1: TCH EOL
JRST FALSE
;PRINT NON-LIST DATA
PRATM: LDT 2,1
HLRZ 3,EVATAB(2) ;USER PRINTING FN FOR THIS TYPE?
JUMPE 3,PRATM2
CAIE 3,-1
JRST PRUDT ;YES.
PRATM2: CAIN 2,ARRAYT
JRST PRARR ;ARRAY PRINT
CAIN 2,ATOMT
JRST PRAT ;ATOM
CAIN 2,FLOATT
JRST PRFLT ;FLOATING POINT NUMBER
CAIE 2,SMALLT
CAIN 2,FIXT
JRST PRNUM ;INTEGER
CAIE 2,PNAMT
CAIN 2,STPTT
JRST PRSTR ;STRING
CAIN 2,STKPT
JRST PRSTK
PRABAD: MOVEI 4,"#"
MOVEI 3,1
MOVEI 2,10
JRST APTX
PRNUM: CALL IUNBOX
MOVEI 4,0 ;SETUP FOR APT
MOVEI 3,0
MOVE 2,URADIX
TLNN F,PRXFLG
MOVEI 2,12 ;RADIX DISABLED FOR IPRE
JUMPGE 1,PRA2
TLNN F,PNEGF ;SKIP ON PRINT SIGN FOR MINUS
JRST PRA2
MOVN 1,1
ADDI 3,1 ;AN EXTRA CHAR
MOVEI 4,"-" ;PREFIX CHAR IS -
PRA2: CAIN 2,10
TLNN F,PDQFLG
JRST APTX
JUMPL 1,.+3
CAMGE 1,2
JRST APTX
CALL APTX
ADDI 3,1
TCH "Q" ;Q AFTER OCTAL NUM IF PRIN2 AND NUM>7
RET
PRSTK: PUSH PP,1
CALL PRABAD ;PRINT #PTRLOC
TCH "/"
POP PP,1
MOVE 1,0(1)
JUMPE 1,PRABAD ;CONTENTS 0 , PRINT AS #0
GETNAR 2,1
GETBAS 3,1
ADDI 2,1(3)
HRRZ 1,0(2)
JRST PRATM
PRUDT: PUSHN F ;SAVE PRINT STATUS
PUSHN FX
PUSHN PREX
PUSH CP,PBTAB
PUSH PP,1
PUSH PP,3 ;APPLY THE ITEM TO THE FN
PUSH PP,1
MOVEI 1,1
CALL EVCC
POP PP,3
POP CP,PBTAB
POPN PREX
POPN FX ;GET FILE INDEX BACK
STE 1,LIST ;IS RESULT A LIST?
JRST PRUDT2 ;NO, PRINT IN NORMAL FASION.
MOVE F,0(CP) ;GET FLAGS
TLZ F,PDQFLG ;TURNOFF ESCAPE
PUSH PP,1
CARA 1,1
CAME 1,KNIL ;IS CAR NIL?
CALL PRE ;NO, PRINT IT.
POPN F ;RESTORE FLAGS
POP PP,1
CDRA 1,1 ;PRINT THE REST OF THE LIST
JRST PRE
PRUDT2: POPN F
MOVEI 1,(3)
LDT 2,1
JRST PRATM2
;PRINT ATOM
PRAT: CAMN 1,KPER ;PERIOD?
JRST PRAPER ;YES, PRINT WITH DOUBLEQUOTES MAYBE
PRAP2: HLRZ 1,2(1) ;GET PNAME POINTER
PRAST: CALL UPATM ;SETUP BYTE AND COUNT
JUMPE 4,R ;NO CHARS?
JUMPL FX,PRA8 ;REAL FILE?
TRNN F,PMCFLG ;CHECK MARGIN?
JRST PRA8 ;NO
HRRZ 1,CHPOS(FX) ;POSITION ON LINE
ADDI 1,0(4)
CAMLE 1,LINSIZ ;WILL EXCEED RIGHT MARGIN?
TCH EOL ;YES, CR
PRA8:
PRA5: ILDB 1,3
TLNN F,PDQFLG ;IF ESCAPE DISABLED,
JRST PRA6 ;DO NOT CHECK FOR SPECIAL CHAR
MOVEI 5,0(1)
MOVE 1,@PBTAB
TLNE 1,PRTBIT
TCH ESC ;SO PRINT ESCAPE
PRA7: MOVEI 1,0(5)
PRA6: CALL PREC
SOJG 4,PRA5 ;COUNT CHARACTERS
RET
PRAPER: TLNN F,PDQFLG ;PRINTING ESCAPE?
JRST PRAP2 ;NO
TCH ESC
TCH "."
RET
UPATM: STE 1,PNAM
JRST PRAT1
MOVEI 3,0(1)
HRLI 3,440700 ;MAKE INTO BYTE POINTER
ILDB 4,3 ;GET CHAR COUNT
JRST PRAT2
PRAT1: SBPC 3,1 ;STRING TO BYTE POINTER CONVERSION
PRAT2: MOVEM 3,UPATP
MOVEM 4,UPATC
RET
UPA: SOSGE UPATC ;COUNT CHARS
RET
ILDB 1,UPATP
JRST RSKP
U UPATP
U UPATC
;FLOATING POINT OUTPUT
A==3
B==4
C==5
W1==6
W2==7
PRFLT:
IFE TEN50,< MOVE 2,0(1)
MOVE 1,IOFNMP
MOVE 3,FLTFMC
FP4: FLOUT
JRST FP2 ;ERR RET, MAKE SURE BAD FORMAT
FP3: PUSHN 1
MOVE 5,IOFNMP
FP1: ILDB 1,5
CALL PREC
CAME 5,0(CP)
JRST FP1
POPN 2
RET
FP2: CAME 1,IOFNMP ;BAD FORMAT?
JRST FP3 ;NO, JUST OVERFLOWED, GO ON
HRLZI 3,4000 ;USE STANDARD FORMAT
JRST FP4
U FLTFMC
; FLOATING FORMAT
FLTFMF: CAMN 1,KNIL
JRST FLTFM1
CAMN 1,KT
SKIPA 1,[XWD 4000,0]
CALL IUNBOX
EXCH 1,FLTFMC
JRST MKN
FLTFM1: MOVE 1,FLTFMC
JRST MKN
>
IFN TEN50,< MOVE 1,0(1)
MOVE A,1
JUMPG A,TFLOT1
JUMPE A,FP1A
MOVNS A
TCH "-"
TLZE A,400000
JRST FP1A
TFLOT1: MOVEI 2,↑D10
TLNN A,400
JRST APT ;IF UNNORMALIZED, TYPE AS DEC INTEGER??
FP1: MOVEI B,0
CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP1A: MOVEI C,0
FP3: MULI A,400
ASHC B,-243(A)
SETZM TEM1 ;INIT 8 DIGIT COUNTER
SKIPE A,B ;DONT TYPE A LEADING 0
PUSHJ CP,FP7 ;PRINT INTEGER PART OF 8 DIGITS
TCH "."
MOVNI A,10
ADD A,TEM1
MOVE W1,C
FP3A: MOVE 1,W1
MULI 1,12
MOVE W1,2
PUSHJ CP,FP7B
SKIPE ,W1
AOJL A,FP3A
POPJ CP,
FP4: MOVNI C,6
MOVEI W2,0
FP4A: ASH W2,1
XCT FPCP(B)
JRST FP4B
FMPR A,@FPCP+1(B)
IORI W2,1
FP4B: AOJN C,FP4A
PUSH CP,W2 ;SAVE EXPONENT
PUSH CP,B ;SAVE SIGN
PUSHJ CP,FP3 ;PRINT FFF.FFF PART OF NUMBER
TCH "E"
POP CP,1
JUMPG 1,.+2
TCH "-"
POP CP,A ;GET EXPONENT BACK
FP7: IDIVI A,12 ;DECIMAL OUTPUT SUBROUTINE
AOS TEM1
HRLM B,0(CP)
JUMPE A,FP7A1
PUSHJ CP,FP7
FP7A1: HLRZ 1,0(CP)
FP7B: ADDI 1,260
JRST @PREX ;TYPE CHAR
353473426555 ;1.0E32
266434157116 ;1.0E16
FT8: 233575360400 ;1.0E8
216470400000 ;1.0E4
207620000000 ;1.0E2
204500000000 ;1.0E1
FT: 201400000000 ;1.0E0
026637304365 ;1.0E-32
113715126246 ;1.0E-16
146527461671 ;1.0E-8
163643334273 ;1.0E-4
172507534122 ;1.0E-2
FT01: 175631463146 ;1.0E-1
FT0=FT01+1
FPCP: CAMLE A,FT0(C)
CAMGE A,FT(C)
Z FT0(C)
U TEM1
>
;PRINT STRING
PRSTR: CALL UPATM
JUMPL FX,PRSTR4 ;REAL FILE?
TRNN F,PMCFLG ;CHECK MARGIN?
JRST PRSTR4 ;NO
HRRZ 1,CHPOS(FX)
ADDI 1,0(4)
CAMLE 1,LINSIZ ;EXCEED MARGIN?
TCH EOL ;YES - PRINT C.R.
PRSTR4: TLNE F,PDQFLG
TCH 42 ;PRINT DOUBLE QUOTE
JUMPLE 4,PRSTR1 ;ANY CHARS?
PRSTR2: ILDB 1,3
PRSTR5: TLNN F,PDQFLG ;PRINTING ESCAPES?
JRST PRSTR3 ;NO
CAIE 1,ESC ;CHAR IS " OR ESC ?
CAIN 1,42
TCH ESC ;YES - PRINT ESCAPE
PRSTR3: CALL PREC
SOJG 4,PRSTR2
PRSTR1: TLNE F,PDQFLG
TCH 42
RET
;PRINT ROUTINES NOT YET IMPLEMENTED
PRARR: JRST PRABAD ;ARRAY
;SYSOUT AND SYSIN
SYSOUT: SETZM ZORGJQ
CALL IOFN
MOVSI 1,400001
GTJFN
JRST [HRRZ 2,1(VP)
JRST OPNER3]
HRRZM 1,SYSJFN
MOVE 2,[XWD 440000,102000] ;36BIT, WRITE, THAWED.
OPENF
JRST [HRRZ 1,SYSJFN
RLJFN
JFCL
HRRZ 2,1(VP)
JRST OPNER3] ;CANNOT OPEN FILE ERROR
MOVE 1,[XWD 10,GCAC2] ;SAVE AC'S 10-17
BLT 1,GCAC2+7 ;FOR RETURN FROM SYSIN.
SYSOUE: MOVEM F,TFLGS
HRRZ 1,SYSJFN
MOVE 2,[POINT 36,[XWD 1000,1 ;WORD 0 (SEE JSYS MANUAL
0 ;SECT. 7 P 2. WORD1 DONE LATER.
XWD 1,140]] ;ENTRY VEC TO BOOT.
MOVNI 3,3 ;COUNT
SOUT
SKIPN ZORGJQ
SKIPA 2,[SIXBIT /SYSOUT/]
MOVE 2,[SIXBIT /MAKSYS/]
BOUT
MOVE 2,SYSDAT ;SYSDAT TO W4 OF FILE FOR SYSIN CHECK
BOUT
MOVE 2,[POINT 36,DADDYN]
MOVNI 3,↑D31 ;30 FOR DADDYNAME +1 FOR 1STFPN
SOUT
;Later we will emit main fork page 0 (which contains the bootstrap
;to unscramble all that comes later) and then go back and write the map
;word for GET to use over the zero at file word 1 above.
SKIPN ZORGJQ
SKIPA 3,[SYSBIT+PVTBIT]
SETZ 3,
CALL SYSMAP ;WRITE OUT MAP WORDS FOR THE WORLD.
HRRZ 1,SYSJFN
RFPTR
JSYS JSYSER
LSH 2,-LPS ;SKIP TO PAGE BOUND
ADD 2,[XWD 520000,1] ;PROT. FOR PMAP=520;+1 TO NXT PG.
HRRZI 3,1 ;NOW REPLACE 0 AT W1 WITH REGULAR GET
ROUT
HRRZI 2,(2)
HRRZI 3,↑D35 ;1STFPN WORD GIVES 1ST FILE PAGE NUM
ROUT ;DONE IN PAGE MODE.
HRRZI 6,(2) ;SAVE PBOUND
HRLI 1,400000 ;KEEP JFN BUT CLOSE TO MAKE SURE FILE
CLOSF
JSYS JSYSER ;REALLY THERE FOR UPCOMING INPUT GTJFN
MOVE 1,IOFNMP
HRRZ 2,SYSJFN
SETZ 3,
JFNS
MOVE 2,IOFNMP ;NAME (JFNS OUTPUT) FOR GETTING INPUT JFN
HRLZI 1,100001 ;OLD FILE NOW.
GTJFN
JSYS JSYSER
HRLM 1,SYSJFN ;LH=READ JFN; RH=WRITE JFN NOW
MOVE 2,[XWD 440000,202000] ;36 BIT READ THAWED
OPENF
JSYS JSYSER
HRRZI 2,↑D36 ;SKIP TO 1ST MAPWORD
SFPTR
JSYS JSYSER
HRRZ 1,SYSJFN
MOVE 2,[XWD 440000,102000] ;AS BEFORE
OPENF
JSYS JSYSER
HRRZI 2,(6)
LSH 2,LPS
SFPTR ;READY TO WRITE PAGES AT END.
JSYS JSYSER
SYSPLP: HLRZ 1,SYSJFN
BIN ;READ 1 MAP WORD.
JUMPE 2,SYSDON
HRRZ 1,SYSJFN ;OUTPUT JFN AGAIN
TRNE 2,7000 ;0 HERE SEZ MAIN FORK
JRST SYSHPG
HLRZ 3,2
LSH 3,LPS
MOVNS 3
LSH 2,LPS
HRLI 2,444400
SOUT
JRST SYSPLP
SYSHPG: HLRZ 6,2 ;PAGE CNT
HRRZI 5,(2)
ANDI 5,777 ;FORK PAGE NUM
LSH 2,-LPS
ANDI 2,7 ;FORK NUMBER,+1
SOSGE 2
0
HRL 5,SWFRKS(2) ;FORK HANDLE
HPGLP: MOVE 1,5
MOVE 2,[XWD 400000,777]
HRLZI 3,100000
PMAP
HRRZ 1,SYSJFN
MOVNI 3,1000
MOVE 2,[POINT 36,777000]
SOUT
AOS 5
SOJG 6,HPGLP
JRST SYSPLP
SYSDON: SKIPE ZORGJQ
JRST SYSDN1
HRRZ 1,SYSJFN
CALL FILNM
PUSH PP,1
HLRZ 1,SYSJFN
CLOSF ;CLOSE READING JFN FIRST SO THAT EOF RESET RIGHT
JFCL
HRRZ 1,SYSJFN
CLOSF
JFCL
POP PP,1
RET
SYSDN1: HLRZ 1,SYSJFN
CLOSF ;CLOSE JFN FOR READING & RELEASE
JFCL
HRRZ 1,SYSJFN
HRLI 1,400000
CLOSF ;CLOSE WRITING ONE, DON'T RELEASE. IT'S CLOSED
JFCL ;SECOND TO GET EOF RESET TO END.
HRRZ 6,SYSJFN ;PARAM FOR MBOOT.
JRST MBOOT
;"Return" from MAKESYS or SYSOUT when it's run.
SYSINR: HRRZI 1,400000
MOVE 2,[XWD 2,EVEC]
SEVEC
HRRZ 1,MYJFNS
JUMPE 1,MKSYSA ;MAKESYS
MOVE 1,[XWD MYFRKS+1,SWFRKS] ;CROCK: 1ST FORK IN MYFRKS
;ACTUALLY MAINFORK (400000)
HRRZI 2,SWFRKS-1
BLT 1,NSWFRKS(2)
MOVE 1,[XWD GCAC2,10]
BLT 1,17
MOVE F,TFLGS
SETZM FR ;SET CURRENT FILES TO TTY
SETZM DRIBFX ;TURN OFF ANY DRIBBLING
MOVEI 1,1
MOVEM 1,FP
MOVSI 3,-NFILES+2 ;CLEAR FILE TABLE
SETZM FILEA+2(3)
AOBJN 3,.-1
TIME
MOVEM 1,LOGTOD
GETJRT
MOVEM 1,LOGRT
SETZM GCRT
CALL SETTRP ;MAGIC PP OVERFLOW PAGE-INIT PROTECTION
CALL RESTCB ;Restore swapping buffer.
; JSYS BRREST ;I have taken this out N times now.
;I keep putting it back, but it is
;unnecessary & wrong, given RESTCB.
CALL SETINT
CALL SETMOD
HLRZ 1,MYJFNS
CALL FILNM
PUSH PP,1
HRRZ 1,MYJFNS
JUMPN 1,.+2
SKIPA 1,KNIL
CALL FILNM
POP PP,2
JRST CONS
SYSMAP: SETZB 1,ZPAGE ;ITERATE THRU PP 0 TO ENDCOR ON ZPAGE
SETZM LPAGE ;COUNT # PP IN A ROW TO BE SAVED
SYMP1: SKIPN 2,TYPTAB(1)
JRST SYMPDN
JUMPE 3,SYMPS ;0=> MAKESYS - SAVE ALL
TLNE 2,PVTBIT
JRST SYMPS ;SAVE IF PVTBIT=1
TLNE 2,SYSBIT
JRST SYMPNX ;DONT SAVE IF SYSBIT=1
SYMPS: MOVEI 2,0(2)
CAIN 2,BTABT ;NEVER SAVE BITTABLE PAGES
JRST SYMPNX
CAMN 1,PPTRP ;DON'T SAVE PDLOV TRAP PAGE
JRST SYMPNX
SKIPN CBSIZE ;IF THERE'S A SWAPPING BUFFER,
JRST SYMP2
CAMG 1,CBRANG+1 ;DON'T SAVE SWAPPING BUFFER
CAMGE 1,CBRANG
SKIPA 2,CBTHED ;OR CORE BUFFER TABLE PAGE
JRST SYMPNX
CAIN 1,(2)
JRST SYMPNX
SYMP2: HRLI 1,400000
RPACS
TLNE 2,10000 ;PAGE MUST EXIST TOO
AOSA LPAGE ;COUNT 1 GOOD PAGE TO EMIT.
SYMPNX: CALL SMEMIT ;EMIT 'EM WHEN FIND 1ST BAD 1
AOS 1,ZPAGE ;READY TO CHECK NEXT PAGE
JRST SYMP1
SMEMIT: SKIPN 1,LPAGE ;COUNT PP THIS BLOCK
RET ;NONE
HRRZ 2,ZPAGE
SUBI 2,(1) ;RH=1ST PAGE IN GROUP
HRLI 2,(1) ;LH=COUNT
HRRZ 1,SYSJFN
BOUT
SETZM LPAGE
RET
SYMPDN: CALL SMEMIT ;MAKE SURE BLOCK CLOSED OUT
AOS 1,ZPAGE ;COUNT TO NEXT IN CASE REALLY
HRRZI 2,(1) ;NOT DONE
LSH 2,LPS
CAMG 2,ENDCOR
JRST SYMP1
;NOW FOR SHADOW
SETZM LPAGE
SETZB 1,ZPAGE
SMSHLP: CALL GFRKB
CAIN 2,FSYSBT ;SAVE IF PVTBIT 1 OR SYSBIT 0
JUMPN 3,SMSHNX ;OR IF A MAKESYS
HLRZ 2,1
LSH 1,-LPS
ANDI 1,777
HRL 1,SWFRKS(2)
SKIPN SWFRKS(2) ;NOTHING HAS EVER BEEN SWAPPED
JRST SMSHNX ;I ASSUME. IF SO WON'T LOOK FAR.
RPACS
MOVE 1,ZPAGE
TLNE 2,10000
AOSA LPAGE
SMSHNX: CALL SHEMIT
HRRZI 1,1000
ADDB 1,ZPAGE
CAMLE 1,HISHAD
JRST SMSHDN
TRNN 1,777000 ;IF NEXT PAGE 1ST IN ITS FORK
CALL SHEMIT ;FORCE,
JRST SMSHLP
SHEMIT: SKIPN 2,LPAGE
RET
SETZM LPAGE
LSH 1,-LPS
ANDI 1,777
SUBI 1,(2)
HRLI 1,(2) ;1 = COUNT,FORKPAGE
MOVE 2,ZPAGE
SUBI 2,1000 ;ONLY MATTERS IF FORKBOUND FORCED EMIT.
LSH 2,-LPS
ANDI 2,17000 ;GOT THE FORK BITS, BUT MUST OFFSET
ADDI 2,1000 ;BY 1 FOR SYSOUT TO DISTINGUISH MAINFRK
IOR 2,1
HRRZ 1,SYSJFN
BOUT
MOVE 1,ZPAGE
RET
SMSHDN: CALL SHEMIT
HRRZ 1,SYSJFN
SETZ 2,
BOUT ;TERMINAL 0
RET
SYSIN: CALL IOFN
MOVSI 1,(1B2+1B17)
GTJFN
JRST [HRRZ 2,1(VP)
JRST OPNER3]
HRRZI 6,(1)
HRLZI 1,100001
HRROI 2,[ASCIZ /<LISP>BOOT.SAV/]
GTJFN
JRST [HRROI 1,[ASCIZ /NO BOOTSTRAP/]
PSOUT
JRST FALSE]
HRLI 1,400000
GET
HRRZI 1,(6)
JRST 777000
U SYSFIL
U SYSJFN
U ZPAGE
U LPAGE
U ZORGJQ ;FLAG DURING SYSOUT/MAKESYS SEZ WHICH
;IS HAPPENING
MYJFN: HLRZ 1,MYJFNS
JUMPE 1,.+2
AOS (CP)
RET
CLRBUF: IFN TEN50,<
UCLRBF: CLRTIB ;CLEAR TTY IN BUF
>
IFE TEN50,<MOVEI FX,0
JRST CLRBF1
UCLRBF: CALL IFSET
HRRZ 2,2(VP)
CAME 2,KNIL
JUMPE FX,CLRBFS ;SECOND ARG NOT NIL AND FILE TTY
CLRBF1: HRRZ 1,FILEN(FX)
CFIBF
JUMPN FX,FALSE
>
CLRBF3: CALL CLRTTY
JRST FALSE
IFE TEN50,<
CLRBFS: MOVEI FX,0 ;SAVE STUFF IN TTY BUFFERS
HRRZ 1,FILEN(FX)
SKIPG LNBFC
SIBE
JRST .+3
HRRZ 1,FCHAR(FX)
JUMPE 1,CLRBF3 ;NOTHING TO SAVE - DONT CHANGE VALUES
MOVE 1,SYSBFP
MOVEM 1,CSYSBP
MOVEI 1,CLRBFC
CALL CLRBSS
MOVE 1,SLNBFP
MOVEM 1,CSLNBP
HRRZ 1,FCHAR(FX)
SKIPE 1
CLRBF6: IDPB 1,CSLNBP
SOSGE LNBFC
JRST CLRBF3
ILDB 1,LNBFP
JRST CLRBF6
CLRBFC: IDPB 1,CSYSBP
RET
CLRBSS: MOVEM 1,CLRBFI ;ROUTINE TO CALL FOR EACH CHAR
HRRZ 1,FILEN(FX)
RFMOD
MOVEM 2,OLDMOD
TRZ 2,6000 ;SET TO NO ECHO
TRO 2,1B23 ;AND WAKEUP ON EVERYTHING
SFMOD
HRRZ 1,FILEN(FX)
SIBE
JRST CLRBF2
CLRBFO: MOVE 2,OLDMOD
SFMOD
RET
CLRBF2: MOVEM 2,CLRBFN
CLRBF4: HRRZ 1,FILEN(FX)
SOSGE CLRBFN
JRST CLRBFO
BIN
MOVEI 1,0(2)
CALL @ CLRBFI
JRST CLRBF4
U CLRBFN
U CLRBFI
U OLDMOD
SYSBFP: POINT 7,SYSBF,-1
U CSYSBP
U SYSBF,15 ;BUFFER FOR SAVED SYSTEM BUFFER
SLNBFP: POINT 7,SLNBF,-1
U CSLNBP
;MAKE STRING OUT OF SAVED SYSTEM AND LINE BUFFERS
LINBUF: MOVE 6,CSLNBP
MOVE 7,SLNBFP
CAMN 1,KNIL
JRST LINBF1 ;ARG NIL MEANS CLEAR SAVED BUFFER
LINBF3: CAMN 6,7
JRST FALSE
CALL MKSTRS
LINBF2: ILDB 1,7
CALL MKSTR1
CAME 6,7
JRST LINBF2
MOVE 1,UNP1
JRST MKSP
LINBF1: MOVEM 7,CSLNBP
RET
SYSBUF: MOVE 6,CSYSBP
MOVE 7,SYSBFP
CAME 1,KNIL
JRST LINBF3
MOVEM 7,CSYSBP
RET
> ;END OF IFE TEN50
;SETUP FOR INPUT FUNCTION
IFSET: MOVEI FX,FIN ;CHARACTER INPUT ROUTINE
MOVEM FX,RDAX ;INPUT DISPATCH
CAMN 1,KNIL ;STANDARD FILE?
JRST IFS3 ;YES
LDT 5,1
CAIN 5,STPTT ;IS IT A STRING?
JRST IFS6 ;YES
CALL IFSCH ;SEARCH TABLE FOR INPUT FILE
JRST ILLIF ;FAILS
IFS5: MOVEI FX,0(3)
IFS2: MOVEM FX,FRX
RET
IFS6: MOVEI FX,STRIN ;STRING INPUT ROUTINE
MOVEM FX,RDAX ;INPUT DISPATCH
MOVEI FX,NFILES ;FILE NUMBER FOR STRING INPUT
HRRZ 5,FILEA(FX)
CAIN 1,(5) ;SAME STRING AS BEFORE?
JRST IFS2
HRRZ 4,FCHAR(FX) ;NO - SET THINGS UP
SKIPE 4
SOS 0(5) ;BACK UP THE STRING
SETZM FCHAR(FX)
HRRZM 1,FILEA(FX)
JRST IFS2
IFS3: MOVE FX,FR ;USE STANDARD INDEX
JRST IFS2
;SEARCH OPEN FILE TABLE FOR NAME OF INPUT FILE
IOFSCH: MOVEI 5,600000 ;SEARCH FOR I/O FILE
SKIPA
IFSCH: MOVEI 5,400000 ;SEARCH FOR INPUT (ONLY) FILE
PUSH PP,2 ;READ AND FRIENDS HAVE READTBL HERE
PUSH PP,1
IFSC3: MOVSI 3,-NFILES
IFSC1: HLRZ 4,FCHAR(3)
ANDI 4,0(5)
CAIE 4,0(5) ;RIGHT TYPE?
JRST IFSC2 ;NO, IGNORE
HRRZ 4,FILEA(3) ;GET NAME
CAIN 4,0(1)
JRST IFSCG ;FOUND, RETURN SKIPPING
IFSC2: AOBJN 3,IFSC1
IFE TEN50,<
TLON 5,1
CALL IFREC ;TRY AGAIN WITH RECOGNIZED NAME
JRST IFSCB ;ILLEGAL NAME OR NO JFNS AVAIL
JRST IFSC3
>
IFSCB: POP PP,1 ;NOT FOUND RETURN NO-SKIP, ORIG ARG
POP PP,2
RET
IFSCG: SUB PP,BHC+1 ;FOUND - RETURN FULL NAME
POP PP,2
JRST RSKP ;AND SKIP
;SETUP FOR OUTPUT FUNCTION
OFSET: MOVEI FX,FOUT ;CHARACTER OUTPUT ROUTINE
MOVEM FX,PREX ;OUTPUT DISPATCH
CAMN 2,KNIL ;STANDARD FILE?
JRST OFS3 ;YES
CALL OFSCH ;SEARCH TABLE FOR NAME
JRST OFS4 ;NOT FOUND
OFS5: MOVEI FX,0(3) ;INDEX
OFS2: MOVEM FX,FPX
RET
OFS4: PUSH PP,1 ;TRY IO FILE
MOVEI 1,0(2)
CALL IOFSCH
JRST ILLIF ;NO FOUND - GIVE UP
MOVEI 2,0(1)
POP PP,1
JRST OFS5
OFS3: MOVE FX,FP ;USE STANDARD FILE
JRST OFS2
;SEARCH OPEN FILE TABLE FOR NAME OF OUTPUT FILE
OFSCH: TRZ 5,1 ;SEARCH FOR OUPUT FILE
PUSH PP,2
OFSC3: MOVSI 3,-NFILES
OFSC1: HLRZ 4,FCHAR(3)
ANDI 4,200000
CAIE 4,200000
JRST OFSC2
HRRZ 4,FILEA(3) ;GET NAME
CAIN 4,0(2)
JRST OFSCG ;FOUND, RETURN SKIPPING
OFSC2: AOBJN 3,OFSC1
IFE TEN50,<
TRON 5,1
CALL OFREC ;NOT FOUND - TRY FULL NAME
JRST OFSCB ;ILLEGAL NAME OR NOT FOUND
JRST OFSC3
>
OFSCG: SUB PP,BHC+1 ;FOUND, RETURN SKIP W. FULL NAME
JRST RSKP
OFSCB: POP PP,2 ;NOT FOUND - RETURN ORIG. NAME
RET
ILLOF: MOVEI 1,0(2)
ILLIF: ERROR1 15,RESET
FSCH: MOVSI 3,-NFILES ;SEARCH FOR INPUT OR OUTPUT FILE
FSC1: HRRZ 4,FILEA(3)
CAIN 4,0(1)
JRST RSKP
AOBJN 3,FSC1
CALL IFSCH
SKIPA
JRST RSKP
MOVEI 2,0(1)
CALL OFSCH
RET
MOVEI 1,0(2)
JRST RSKP
;GIVEN JFN IN 1, GET FULL NAME OF FILE
IFE TEN50,<
FILNM: MOVEI 2,0(1) ;JFN
MOVE 1,IOFNMP
MOVSI 3,(2B2+1B5+1B8+1B11+1B14)
HRRI 3,1
JFNS ;GET STRING
CALL PACS ;SETUP TO MAKE ATOM
MOVE 3,1
MOVE 4,IOFNMP
FILNM1: CAMN 3,4
JRST MKATM ;MAKE ATOM
ILDB 1,4
CALL PAC
JRST FILNM1
;GET FULL NAME OF INPUT FILE
IFREC: CALL IOFN
MOVSI 1,(1B2+1B17) ;OLD FILE - SHORT FORM
IFREC1: GTJFN
JRST FALSE ;BAD NAME OR NO JFNS
PUSH PP,1 ;SAVE JFN
PUSHN 5
CALL FILNM ;GET FILE NAME
POPN 5
EXCH 1,0(PP)
RLJFN ;RELEASE JFN
JFCL
POP PP,1 ;NAME
JRST RSKP
;GGET FULL NAME OF OUTPUT FILE
OFREC: PUSH PP,1
MOVEI 1,0(2)
CAMN 1,KLPT ;LPT IS A CROCK
JRST OFREC3
CALL IOFN
MOVSI 1,(1B0+1B17) ;FOR WRITING - SHORT FORM
CALL IFREC1
SKIPA
OFREC3: AOS 0(CP)
MOVEI 2,0(1)
POP PP,1
RET
>
;GET FOLL NAME OF FILE FOR INPUT
INFILP: IFE TEN50,<
CALL IFREC
JRST FALSE
RET
>
IFN TEN50,<
CALL IFSCH
JRST FALSE
RET
>
;GET FULL NAME OF FILE FOR OUTPUT
OUFILP: MOVEI 2,0(1)
IFE TEN50,< CALL OFREC
>
IFN TEN50,< CALL OFSCH
>
JRST FALSE
MOVEI 1,0(2)
RET
;OPEN FILE FOR INPUT
INFILE: CALL IFSCH ;FILE ALREADY OPEN?
CAMN 1,KNIL ;OR NO NAME GIVEN?
JRST SETINF ;THEN SET STANDARD FILE ONLY
PUSH PP,1 ;SAVE NAME
CALL IOFN ;SETUP NAME STRING FROM ATOM
MOVEI 4,0 ;USE MODE 0
CALL INFIL ;OPEN FILE
IFN TEN50,< JRST OPNER2 ;ERROR RETURN>
CALL IOGB ;ASSIGN SLOT IN FILE TABLE
MOVSI 1,400000
MOVEM 1,FCHAR(2) ;INPUT FILE HAS BIT 0=1
MOVEI FX,0(2)
JRST INPUT2
IFN TEN50,<
OPNER2: POP PP,1
ERROR1 11,RESET
>
;SET STANDARD INPUT FILE
SETINF: MOVE FX,FR
CAMN 1,KNIL ;IF NO NAME GIVEN,
JRST INPUT1 ;RETURN NAME OF CURRENT STANDARD FILE
CALL IFSET ;LOOKUP NAME
INPUT2: EXCH FX,FR ;STANDARD FILE INDEX
INPUT1: HRRZ 1,FILEA(FX) ;GET FILE NAME
RET
;OPEN FILE FOR OUTPUT
OUFILE: MOVEI 2,0(1)
CALL OFSCH ;FILE ALREADY OPEN?
CAMN 1,KNIL ;OR NO NAME GIVEN?
JRST SETOUF ;THEN SET STANDARD FILE ONLY
PUSH PP,1
CALL IOFN ;SETUP NAMD STRING FROM ATOM
MOVEI 4,0 ;MODE 0
CALL OUTFIL ;OPEN FILE
IFN TEN50,< JRST OPNER2>
CALL IOGB ;ASSIGN SLOT IN FILE TABLE
MOVSI 1,200000 ;SET BIT 1 IN FCHAR FOR OUTPUT FILE
MOVEM 1,FCHAR(2)
MOVEI FX,0(2)
JRST OUTPU2
;SET STANDARD OUTPUT FILE
SETOUF: MOVE FX,FP
CAMN 1,KNIL ;IF NO NAME GIVEN
JRST OUTPU1 ;RETURN NAME OF CURRENT STANDARD FILE
MOVEI 2,0(1)
CALL OFSET ;LOOKUP NAME
OUTPU2: EXCH FX,FP ;STANDARD FILE INDEX
OUTPU1: HRRZ 1,FILEA(FX) ;GET NAME
RET
;CLOSE FILE
CLOSLF: CAMN 1,KNIL
JRST CLOS2 ;NO NAME GIVEN, TRY STANDARD FILE
CALL FSCH ;INPUT OR OUTPUT FILE?
JRST ILLIF ;NO, ERROR
CLOS3: HRRZ 1,FILEA(3)
PUSH PP,1 ;SAVE NAME FOR VALUE
MOVEI 2,0(3) ;CHECK FOR ONE OF TWO STANDARD FILES
CAMN 2,FR ;INPUT?
SETZM FR ;YES, RESET TO TTY
MOVEI 1,1
CAMN 2,FP ;OUTPUT?
MOVEM 1,FP ;YES, RESET TO TTY
CAIG 2,1
JRST CLOS4 ;DON'T CLOSE TTY
CAMN 2,DRIBFX ;DONT CLOSE DRIBBLE FILE
JRST CLOS4
SETZM FILEA(2)
HRRZ 1,FILEN(2) ;FILE NUMBER
CALL CLOSEF ;SYSTEM CLOSE FILE
POP PP,1 ;RETURN NAME OF FILE CLOSED
RET
CLOS4: POP PP,1 ;DON'T CLOSE THE FILE
JRST FALSE ;RETURN NIL SO THE USER KNOWS
CLOS2: SKIPE 3,FR ;STND INPUT FILE NOT TTY?
JRST CLOS3 ;YES, CLOSE IT
MOVE 3,FP
CAIE 3,1 ;STND OUTPUT FILE NOT TTY?
JRST CLOS3 ;YES, CLOSE IT
JRST FALSE ;NO FILE TO CLOSE
CLSALL: MOVSI 3,-NFILES ;CLOSE ALL FILES
SKIPE FILEA(3)
CALL CLOS3
AOBJN 3,.-2
JRST FALSE
UCLSAL: CALL OPNLST ;USER CLOSEALL
PUSH PP,1
CALL CLSALL
POP PP,1
RET
OPNLST: HRRZ 1,KNIL
MOVSI 5,-NFILES+2
OPNLS2: SKIPN 2,FILEA+2(5)
JRST OPNLS1
HRRZI 4,2(5)
CAMN 4,DRIBFX ;DONT SHOW DRIBBLE FILE
JRST OPNLS1
EXCH 1,2
CALL CONS
OPNLS1: AOBJN 5,OPNLS2
RET
;OPEN FILE FOR INPUT AND OUTPUT
IFE TEN50,<
IOFILE: CALL IOFSCH
JRST IOFIL1 ;ALREADY THERE
MOVEI FX,0(3)
JRST INPUT1
IOFIL1: PUSH PP,1
CALL IOFN
MOVEI 4,0
CALL IOFIL
CALL IOGB
MOVSI 1,600000
MOVEM 1,FCHAR(2)
MOVEI FX,0(2)
JRST INPUT1
;OPEN FILE - BITS GIVEN
OPENF: PUSH PP,1
MOVEI 1,0(2)
CALL IUNBOX ;BITS
PUSHN 1
HRRZ 1,0(PP)
STE 1,ATOM ;FILE NAME?
JRST OPEN1 ;NO ASSUME JFN
CALL IOFN
MOVSI 1,(1B2+1B17) ;OLD FILE
MOVE 3,0(CP)
TRNN 3,220000 ;READ OR APPEND?
MOVSI 1,(1B0+1B17) ;NO - GET FOR WRITING
GTJFN
JRST OPNER1 ;BAD NAME OR NO JFNS
SKIPA
OPEN1: CALL IUNBOX
MOVE 2,0(CP)
MOVEI 4,0(1)
OPENF
JRST OPNB ;WONT OPEN
CALL IOGB
POPN 1
TRNE 1,020000 ;IF APPEND
TRO 1,100000 ;...SET WRITE
LSH 1,1
ANDI 1,600000
HRLZM 1,FCHAR(2) ;SAVE READ&WRITE BITS
HRRZ 1,FILEA(2) ;FULL NAME
RET
;GET JFN OF OPEN FILE
OPNJFN: CAME 1,KNIL
CALL OPENP
CAMN 1,KNIL
JRST OPNJX
HRRZ 1,FILEN(3)
JRST MKN
OPNJX: HRRZ 1,1(VP)
JRST ILLIF
> ;END OF IFE TEN50
; SET THE DRIBBLE FILE
SETDRB: CAMN 1,KNIL ;NIL?
JRST SETDB2 ;YES, TURN OFF DRIBBLING
MOVE 2,1
CALL OFSET ;FIND THE FILE
CAIN FX,1 ;TTY?
SETDB2: SETZ FX, ;YES, EQUIV TO NIL
EXCH FX,DRIBFX
DRIBP2: JUMPE FX,FALSE ;WAS NONE BEFORE
HRRZ 1,FILEA(FX) ;GET PREVIOUS FILE
JUMPE 1,FALSE
RET
; GET THE CURRENT DRIBBLE FILE
DRIBP: MOVE FX,DRIBFX
JRST DRIBP2
;I-O LOCAL SUBR'S
;SETUP FILE NAME STRING FROM ATOM
;ASSIGN SLOT IN OPEN FILE TABLE - JFN IN 1, NAME ON PP
IOGB: MOVSI 2,-NFILES
SKIPN FILEA(2) ;AVAILABLE ENTRY?
JRST IOGB1 ;YES
AOBJN 2,.-2 ;NO
ERROR0 17,RESET ;TOO MANY FILES OPEN
IOGB1: MOVEM 1,FILEN(2) ;FILE NUMBER
SETZM CHPOS(2) ;CLEAR STATE WORDS
EXCH 2,0(PP)
CAMN 2,KLPT ;YEECH - LPT CROCK
SKIPA 1,2
CALL FILNM ;GET FULL FILE NAME
POP PP,2
MOVEM 1,FILEA(2)
RET
IOFN: STN 1,ATOM
JRST ARGNA+1
STE 1,STRNG
ARGNA: ERROR1 16,RESET
HLRZ 1,2(1)
CALL UPATM
MOVE 7,IOFNMP
IOFN1: CALL UPA ;SETUP STRING FOR GTJFN FROM ATOM
JRST IOFN2 ;ATOM FINISHED
IDPB 1,7
JRST IOFN1
IOFN2: SETZ 1,
IDPB 1,7 ;NULL MARKS END OF STRING
MOVE 2,IOFNMP
RET
IOFNMP: POINT 7,IOFNM,-1
U IOFNM,26
IOFIL: MOVEI 3,1B19+1B20 ;READ AND WRITE BITS
SKIPA
INFIL: MOVEI 3,1B19 ;READ BIT FOR OPENF
MOVSI 1,(1B2+1B17) ;OLD FILE BIT+SHORT FORM BIT
OPNFIL: GTJFN
JRST OPNER1 ;ERROR
HRRZS 4,1 ;CLEAR LH
MOVEI 2,0(3) ;GET OPENF FLAGS
HRLI 2,(7B5) ;ASCII CHARACTER SIZE
OPENF
JRST OPNB
RET
OPNB: CAIN 1,OPNX1 ;ALREADY OPEN?
JRST OPNER2 ;YES
MOVEI 1,0(4) ;NO - RELEASE JFN
RLJFN
JFCL
OPNER2: POP PP,1
ERROR1 11,RESET
OPNER1: POP PP,2
OPNER3: EXCH 1,2
CAIE 2,GJFX23
ERROR1 27,RESET
ERROR1 26,RESET ;DIRECTORY FULL
OUTFIL: MOVSI 1,(1B0+1B17) ;FOR WRITING BIT+SHORT FORM BIT
MOVEI 3,1B20
JRST OPNFIL
CLOSEF: CLOSF
JFCL
RET
;NUMBER PRINTERS
PNO8: PUSH CP,2
MOVEI 2,10 ;OCTAL TO TTY
JRST PNO101
PNO10: PUSH CP,2
MOVEI 2,↑D10 ;DECIMAL TO TTY
PNO101: PUSH CP,3
PUSH CP,4
PUSH CP,FX
PUSH CP,PREX
MOVEI FX,0
MOVEI 3,TCO
MOVEM 3,PREX
CALL APT
POP CP,PREX
POP CP,FX
POP CP,4
POP CP,3
POP CP,2
RET
APT: MOVEI 3,0 ;CHAR COUNT
MOVEI 4,0 ;PREFIX
TRO F,PMCFLG ;ENABLE MARGIN CHECKING
APTX: MOVEM 2,APTR ;ANY RADIX OUT VIA PREC
APT1: LSHC 1,-↑D35
LSH 2,-1
DIV 1,APTR
HRLM 2,0(CP)
ADDI 3,1
JUMPE 1,APT4
PUSHJ CP,APT1
APT2: HLRZ 1,0(CP)
ADDI 1,60
PREC: JRST @PREX ;TCO, FOUT OR INTERNAL SUBR
APT4: JUMPL FX,APT5 ;REAL FILE
TRNN F,PMCFLG ;CHECK MARGIN?
JRST APT5 ;NO
HRRZ 1,CHPOS(FX)
ADDI 1,0(3)
CAMLE 1,LINSIZ
TCH EOL
APT5: JUMPE 4,APT2
TCH 0(4)
JRST APT2
CHACCT: CAIGE 1,40 ;COUNT CHARS AND LINES
JRST PRECC
PREC1: AOS CHPOS(FX)
RET
PRECC: CAIE 1,EOL
CAIN 1,15
JRST PRECR
AOS CHPOS(FX)
JRST PREC1
PRECR: HLLOS CHPOS(FX)
JRST PREC1
;OUTPUT CHARACTER TO FILE
FOUT: CALL CHACCT ;ACCOUNT CHARACTER
PUSH CP,2
HRRZ 2,FILEN(FX) ;FILE NUMBER
FOUT4: EXCH 1,2
CAIN 2,EOL
JRST FOUT1
BOUT
FOUT2: EXCH 1,2
CAIN 2,101 ;OUTPUTING TO TTY?
SKIPN 2,DRIBFX ;... AND DRIBBLING?
JRST FOUT5 ;NO
HRRZ 2,FILEN(2) ;YES, DO THE DIRBBLING
JRST FOUT4
FOUT5: POP CP,2
RET
;INPUT CHARACTER FROM FILE
FIN: JUMPE FX,GCHIT ;TTY (LINE BUFFERED) INPUT
FIN1: PUSH CP,2
HRRZ 1,FILEN(FX) ;GET JFN
FIN3: BIN
JUMPE 2,FIN2 ;PROBABLY EOF
CAIE 2,15 ;CR?
JRST FIN4 ;NO
BIN ;FLUSH FOLLOWING LF
CAIE 2,12 ;MAKE SURE IT IS A LF
JRST FIN5
MOVEI 2,EOL ;USE EOL
FIN4: MOVE 1,2
JUMPN FX,FIN6 ;GO ACCOUNT CHARACTER
MOVEI FX,1 ;IF TTY IN,
HRRZ 2,TTYTBL ;CHECK ECHO
SKIPN ECHMDW(2)
JRST FIN7 ;OFF
FIN6: MOVE 2,0(CP)
CALL CHACCT ;ACCOUNT AS FOR TTY OUT
FIN7: POP CP,2
MOVE FX,FRX
RET
FIN5: BKJFN ;CR WTH NO LF, BACKUP ONE CHAR
JFCL ;(WHO CAN IT FAIL?)
MOVEI 2,15 ;RETURN CR
JRST FIN4
FOUT1: MOVEI 2,15 ;CONVERT TO CR,LF
BOUT
MOVEI 2,12
BOUT
MOVEI 2,EOL
JRST FOUT2
FIN2: GTSTS
TLNN 2,1B26 ;EOF?
JRST FIN3
MOVEI 3,0(FX) ;YES
CALL CLOS3 ;CLOSE FILE
ERROR1 20,RESET
;READ A CHAR FROM A STRING
; THE STRING POINTER IS KEPT IN BOXED FORM ONLY SO THAT
; WE ARE OK IF A GC OCCURS AND THE STRING MOVES
STRIN: HRRZ 7,FILEA(FX) ;GET THE STRING
MOVE 3,(7)
USBPC 1,3
SOJL 2,STREOF ;EMPY STRING
ADD 3,[-7777777] ;LENGTH-1 & CHAR POS + 1
MOVEM 3,0(7) ;RESTORE STRING POINTER
ILDB 1,1 ;GET THE CHAR OUT
RET
STREOF: ERROR0 20,RESET ;GIVE AN END OF FILE ERROR
U PREX
U APTR
;INITIAL OBLIST
;NM IS ATOM NAME, F IS LOC OF FUNCTION CODE IF ANY,
;L IS LOC OF CELL TO RECEIVE ATOM IF ANY
;T IS FN TYPE
DEFINE ATM (NM,F,L,NA,T)
< SIXBIT /NM /
XWD F,L
IFB <NA>,<EXP 0>
IFNB <NA>,<IFB <T>,<XWD NA*40,0>
IFNB <T>,<XWD NA*40,T*1000>>
NIATOM==NIATOM+1>
NIATOM==0
;TYPES ARE: 0 NORMAL
; 1 NO-EVAL SPREAD
; 2 EVAL, NO-SPREAD
; 3 NO-EVAL, NO-SPREAD
FOO:
LOC ENDTMP
IATOMS==ENDTMP
ATM <NIL>,,KNIL
ATM <NOBIND>,,KNOB
ATM <T>,,KT
ATM <.>,,KPER
ATM <LAMBDA>,,KLAM
ATM <NLAMBDA>,,KNLA
ATM <FUNARG>,,KFNARG
ATM <LPT:>,,KLPT
ATM <*PROG*LAM>,,KPRGLM
ATM <*FORM*>,,KFORM
ATM <*FN*>,,KFN
ATM <*TAIL*>,,KTAIL
ATM <*ARGVAL*>,,KAVAL
ATM <READX>,READX,KREADX,0
ATM <PRINTX>,PRINTX,KPRINT,1
ATM <APPLYX>,APPLY,KAPPLY,2
ATM <APPLY*>,APPLY.,KAPP.,1,2
ATM <EVALQT>,EVALQT,KEVLQT,0
ATM <INTERRUPT>,APPLY,KINT,2
ATM <FAULTEVAL>,FAULTX,KFAULT,1,3
ATM <FAULTAPPLY>,FAULTX,KFALTA,1,3
ATM <FNCLOSER>,FNCLSR,,3
ATM <FNCLOSERA>,FNCLSA,,3
ATM <FNCLOSERD>,FNCLSD,,3
ATM <FNOPENR>,FNOPNR,,2
ATM <FNOPENRA>,FNOPNA,,2
ATM <FNOPENRD>,FNOPND,,2
ATM <ECHOMODE>,ECHMOD,,2
ATM <ERRORX>,ERRX,KERRX,1
ATM <ERRORSET>,ERRSET,KERSET,3
ATM <ESGAG>,,KESGAG
ATM <SYSHASHARRAY>,,KSYSHS
ATM <PRXFLG>,,KPRXFL,1
ATM <ALLOCATE>,ALLOCA,,1
ATM <AND>,AND,,1,3
ATM <APPLY>,APPLY,,3
ATM <ARG>,ARGN,,2,1
ATM <ARGTYPE>,ARGTY,,1
ATM <ARRAY>,ARRAY,,3
ATM <ARRAYBEG>,UFBA,,1
ATM <ARRAYP>,ARRAYP,,1
ATM <ASSED>,ASSED,,2
ATM <ATOM>,ATOM,,1
ATM <BACKTRACE>,UBAKTR,,3
ATM <BKLINBUF>,BKLNBF,,1
ATM <BKSYSBUF>,BKSYSB,,1
ATM <BLIPVAL>,FNDEVL,,3
ATM <BLIPSCAN>,BLPSCN,,2
ATM <BOXCOUNT>,BOXCNT,,2
ATM <CAR>,CAR,,1
ATM <CCODEP>,CCODEP,,1
ATM <CDR>,CDR,,1
ATM <CHARACTER>,CHRCT,,1
ATM <CHCON>,CHCON,,3
ATM <CHCON1>,CHCON1,,1
ATM <CLEARBUF>,UCLRBF,,2
ATM <CLEARSTK>,CLRSTK,,1
ATM <CLRHASH>,CLRHSH,,1
ATM <CLOCK>,CLOCK,,1
ATM <CLOSEALL>,UCLSAL,,0
ATM <CLOSEF>,CLOSLF,,1
ATM <CLOSER>,CLOSER,,2
ATM <CONCAT>,CONCAT,,1,2
ATM <COND>,COND,,1,3
ATM <CONS>,CONS,,2
ATM <CONSCOUNT>,CONSCF,,1
ATM <CONTROL>,CONTRL,,2
ATM <COPYREADTABLE>,CPYRDT,,1
ATM <COPYSTK>,CPYSTK,,2
ATM <COPYTERMTABLE>,CPYTT,,1
ATM <CTRLC>,CTRLC,,1
ATM <DATE>,DATE,,1
ATM <DDT>,DDTC,,0
ATM <DEFEVAL>,DEFEVA,,2
ATM <DEFPRINT>,DEFPRI,,2
ATM <DEFTYPE>,DEFTYP,,2
ATM <DISABLECHAR>,DISABL,,1
ATM <DRIBBLEFILE>,DRIBP,,0
ATM <ELT>,ELT,,2
ATM <ELTD>,ELTD,,2
ATM <ENABLECHAR>,ENABLE,,2
ATM <ENVAPPLY>,ENVAPPLY,,6
ATM <ENVEVAL>,ENVEVL,,5
ATM <EQ>,EQ,,2
ATM <EQP>,EQP,,2
ATM <ERROR>,ERROR,,1
ATM <ERRORM>,ERRORM,,1
ATM <ERRORN>,ERRORN,,0
ATM <ERRORSTRING>,ESTRNG,,1
ATM <ERRORX1>,ERRX,,0
ATM <ERROR!>,ERRORF,,0
ATM <ESCAPE>,ESCP,,1
ATM <EVAL>,EVAL,KEVAL,2
ATM <EVALA>,EVALA,,2
ATM <EVALV>,EVALV,,2
ATM <EXPRP>,EXPRP,,1
ATM <FGREATERP>,FGTP,,2
ATM <FGTP>,FGTP,,2
ATM <FLOATP>,FLOATP,,1
ATM <FLTFMT>,FLTFMF,,1
ATM <FMEMB>,FMEMB,,2
ATM <FPLUS>,FPLUS,,1,2
ATM <FQUOTIENT>,FQTENT,,2
ATM <FRAMESCAN>,FRMSCN,,2
ATM <FREMAINDER>,FRMNDR,,2
ATM <FRPLACA>,RPLACA,,2
ATM <FRPLACD>,RPLACD,,2
ATM <FTIMES>,FTIMES,,1,2
ATM <FUNCT1>,FUNCT1,,1
ATM <FUNCTION>,CAR,,1,3
ATM <GCGAG>,GCGAG,,1
ATM <GCTRP>,GCTRP,,1
ATM <GETD>,GETD,,1
ATM <GETBLK>,GETBLK,,1
ATM <GETBRK>,GETBRK,,1
ATM <GETHASH>,GETHSH,,2
ATM <GETNPTRS>,GTNPTR,,1
ATM <GETNWRDS>,GTNWRD,,1
ATM <GETPROPLIST>,CDR,,1
ATM <GETSEPR>,GETSEP,,1
ATM <GETREADTABLE>,GETRDT,,1
ATM <GETTERMTABLE>,GETTY,,1
ATM <GETTOPVAL>,CAR,,1
ATM <GLC>,GLC,,1
ATM <GNC>,GNC,,1
ATM <GO>,GO,,1,3
ATM <GREATERP>,GRTRP,,2
ATM <HERALD>,HERALD,,1
ATM <HANDLEP>,HANDLP,,1
ATM <IEQP>,IEQP,,2
ATM <IGREATERP>,IGRTRP,,2
ATM <INFILE>,INFILE,,1
ATM <INFILEP>,INFILP,,1
ATM <INPUT>,SETINF,KINPUT,1
ATM <INREADMACROP>,INRMP,,0
ATM <IOFILE>,IOFILE,,1
ATM <IPLUS>,IPLUS,,1,2
ATM <IQUOTIENT>,IQTENT,,2
ATM <IREMAINDER>,IRMNDR,,2
ATM <ITIMES>,ITIMES,,1,2
ATM <JSYS>,UJSYS,,5
ATM <LASTC>,LASTC,,1
ATM <LINBUF>,LINBUF,,1
ATM <LINELENGTH>,LINLTH,,1
ATM <LIST>,LIST,,1,2
ATM <LISTP>,LISTP,,1
ATM <LITATOM>,LITATM,,1
ATM <LLSH>,LSHFT,,2
ATM <LOC>,MKN,,1
ATM <LOGAND>,LOGAND,,1,2
ATM <LOGOR>,LOGOR,,1,2
ATM <LOGOUT>,LOGOUT,,0
ATM <LOGXOR>,LOGXOR,,1,2
ATM <LSH>,ASHFT,,2
ATM <MAKESYS>,MKSYS,,2
ATM <MAPATOMS>,MPATMS,,1
ATM <MINFS>,MINFS,,2
ATM <MINHASH>,MINHSH,,1
ATM <MINUS>,MINUS,,1
ATM <MINUSP>,MINUSP,,1
ATM <MKATOM>,MKATOM,,1
ATM <MKHANDLE>,UMKHDL,,1
ATM <MKSTRING>,MKSTR,,1
ATM <NALLOC>,NALLOC,,1
ATM <NCHARS>,NCHARS,,3
ATM <NCONC>,NCONC,,1,2
ATM <NONAC>,NONAC,,1
ATM <NOT>,NULL,,1
ATM <NTHCHAR>,NTHCHR,,4
ATM <NTYP>,NTYP,,1
ATM <NULL>,NULL,,1
ATM <NUMBERP>,NUMBRP,,1
ATM <OPENF>,OPENF,,2
ATM <OPENP>,OPENP,,2
ATM <OPENR>,OPENR,,1
ATM <OPNJFN>,OPNJFN,,2
ATM <OR>,OR,,1,3
ATM <ORIG>,,KORIG
ATM <OUTFILE>,OUFILE,,1
ATM <OUTFILEP>,OUFILP,,1
ATM <OUTPUT>,SETOUF,KOUTPU,1
ATM <PACK>,PACK,,1
ATM <PACKC>,PACKC,,1
ATM <PEEKC>,PEEKC,,2
ATM <PLUS>,PLUS,,1,2
ATM <POSITION>,POSITN,,2
ATM <PRIN1>,PRIN1,,2
ATM <PRIN2>,PRIN2,,3
ATM <PRIN3>,PRIN3,,2
ATM <PRIN4>,PRIN4,,3
ATM <PRINT>,PRINT,,3
ATM <PRINTLEVEL>,SETPLV,,1
ATM <PROG>,PROG,KPROG,1,3
ATM <PROG1>,PROG1,,1,3
ATM <PROG2>,PROGN,,1,3
ATM <PROGN>,PROGN,,1,3
ATM <PUTD>,PUTD,,2
ATM <PUTHASH>,PUTHSH,,3
ATM <QUOTE>,CAR,,1,3
ATM <QUOTIENT>,QTENT,,2
ATM <RADIX>,RADIKS,,1
ATM <RAISE>,RAISE,,2
ATM <RATEST>,RATEST,,1
ATM <RATOM>,RATOM,,2
ATM <READ>,READ,,3
ATM <READC>,READC,,2
ATM <READMACROS>,RDMACS,,1
ATM <READP>,READP,,2
ATM <READTABLEP>,RDTBLP,,1
ATM <RECLAIM>,RECLM,,1
ATM <REHASH>,UREHSH,,2
ATM <RELBLK>,RELBLK,KRLBLK,2
ATM <RELOC>,REL,,2
ATM <RELSTK>,RELSTK,,1
ATM <REMAINDER>,RMNDR,,2
ATM <RESETREADTABLE>,RSTRDT,,2
ATM <RESETTERMTABLE>,RSTTBL,,2
ATM <SCODEP>,SCODEP,,1
ATM <RESET>,RESETE,,0
ATM <RESETREADTABLE>,RSTRDT,,2
ATM <RETFROM>,RETFRM,,3
ATM <RETTO>,RETTO,,3
ATM <RETURN>,RETURN,,1
ATM <RPLACA>,RPLACA,,2
ATM <RPLACD>,RPLACD,,2
ATM <RPLSTRING>,RPLSTR,,3
ATM <RSTRING>,RSTRNG,,2
ATM <SET>,SET,,2
ATM <SETARG>,SETARG,,3,1
ATM <SETBLIPVAL>,SETBLP,,4
ATM <SETBRK>,SETBRK,,3
ATM <SETDRIBBLEFILE>,SETDRB,,1
ATM <SETERRORN>,SERRN,,2
ATM <SETINC>,SETINC,,2
ATM <SETN>,SETN,,2,1
ATM <SETPROPLIST>,RPLACD,,2
ATM <SETREADMACROFLG>,SRMF,,1
ATM <SETREADTABLE>,SETRDT,,2
ATM <SETTERMTABLE>,TRMTBL,,1
ATM <SETSBSIZE>,SSBSIZ,,1
ATM <SETSEPR>,SETSEP,,3
ATM <SETSTKARG>,SSTKAR,,3
ATM <SETSTKARGNAME>,SSTKAN,,3
ATM <SETTOPVAL>,RPLACA,,2
ATM <SETQ>,SETQ,,1,3
IFE TEN50,<
ATM <SFPTR>,SPTR,,2
>
ATM <SPACES>,SPACES,,2
ATM <STACKP>,STKPP,,1
ATM <STKARG>,STKARG,,2
ATM <STKARGNAME>,STKANM,,2
ATM <STKNAME>,STKNAM,,1
ATM <STKNARGS>,STKNRG,,1
ATM <STKNTH>,USTKNT,,3
ATM <STKNTHNAME>,STKNNM,,2
ATM <STKPOS>,USTKPO,,4
ATM <STKSCAN>,STKSCN,,3
ATM <STRINGP>,STRNGP,,1
ATM <SUBRP>,SUBRP,,1
ATM <SUBSTRING>,SUBSTR,,3
ATM <SWPPOS>,SWPPOS,,2
IFE TEN50,<
ATM <SWPARRAY>,SWPARY,,1
ATM <SYSBUF>,SYSBUF,,1
ATM <SYSIN>,SYSIN,,1
ATM <SYSOUT>,SYSOUT,,1
>
ATM <TERMTABLEP>,TTTBLP,,1
ATM <TERPRI>,TERPRI,,1
ATM <TIMES>,TIMES,,1,2
ATM <TRAPCOUNT>,TRAPCT,,1
ATM <TYPESTATUS>,TYPSTS,,2
ATM <UNPACK>,UNPACK,,3
ATM <USED>,INUSE,,2
ATM <USERCONS>,USRCNS,,1,2
ATM <VAG>,GUNBOX,,1
RELOC FOO
;ONE-SHOT INIT, .START OR LISP0$G FROM DDT AFTER LOADING
LISP0: MOVEI 2,ENDTMP ;LAST VARIABLE
ADDI 2,MPS ;BUMP TO NEXT PAGE
TRZ 2,MPS
MOVEM 2,BGNCOR ;USE ABOVE FOR LISP DATA
JRST LISP1
LISP00: HRRZI 1,COREV ;IF COREV=140 YOU OMITTED "/1000O" TO LOADER
CAIN 1,1000 ;BEFORE LOADING LISP.REL IF IT'S 1000, THEN
JRST .+4 ;SUPPOSEDLY OK. OTHER VALUES VERY ODD INDEED.
HRROI 1,[ASCIZ /COREV NOT RIGHT -- SEE LISP00 IN LISP.MAC/]
PSOUT
HALTF
HRRZI 1,DATEWD
CAIN 1,SYSDAT
JRST .+4
HRROI 1,[ASCIZ /DATEWD NEQ SYSDAT - SEE LISP00/]
PSOUT
HALTF
HRRZI 1,BEGTMP
CAILE 1,GCIE
JRST .+4
HRROI 1,[ASCIZ /TIME TO RAISE BEGTMP AGAIN!!/]
PSOUT
HALTF
MOVE 1,LISP0C
MOVEM 1,EVEC+1
HRRI 1,LISP0
MOVEM 1,EVEC
MOVEI 1,400000
MOVE 2,[XWD 2,EVEC] ;DO ONCE BEFORE SAVE
SEVEC
HALTF
U EVEC,2 ;ENTRY VECTOR
LISP2: MOVE CP,ICP ;START AFTER INIT DONE
MOVE PP,IPP ;INCASE PRIN1 IS CALLED BELOW
SKIPE SYSRDT ;HAVE A READTABLE?
JRST LSP2C ;YES
MOVE 1,KORIG ;NO - RESET THE READTABLES
CALL CPYRDT
MOVEM 1,PRVIRT
MOVEM 1,PRVORT
MOVE 2,KT
CALL SETRDT
MOVE 1,KORIG
CALL CPYRDT
MOVE 2,KNIL
CALL SETRDT
LSP2C: SKIPE TTYTBL ;HAVE A TERMINAL TABLE?
JRST .+4 ;YES
MOVE 1,KORIG ;NO - RESET THE TERMINAL TABLE
CALL CPYTT
CALL TRMTBL
HRRZ 3,TTYTBL
MOVE 1,ORGTTY+RASMOD ;MAKE SURE RAISE MODE IS CORRECT
MOVEM 1,RASMOD(3)
MOVEI 1,100
RFMOD
TRNE 2,1B31 ;IS RAISE MODE ON?
SETZM RASMOD(3) ;YES, SET RAISE MODE TO 0.
SKIPN 1,HLDMSG ;USER HERALD?
JRST LSP2B ;NO - PRINT NOTHING
MOVE 2,KT ;YES - SET UP TO PRINT ON TTY
CAMN 1,KT ;IS HERALD = T?
JRST LSP2A ;YES - PRINT STANDARD MESSAGE
CALL PRIN1 ;NO - PRINT THE MESSAGE
JRST LSP2B
LSP2A: TMSG LISPM1
LSP2B: TIME
MOVEM 1,LOGTOD
GETJRT
MOVEM 1,LOGRT
SETZM GCRT
IFE TEN50,<
CALL MYJFN
JRST LISP2S ;NOT MAKESYS
CALL FILNM
MOVE 1,IOFNM
MOVE 2,IOFNM+1
LSH 1,-1
CAME 1,["<HACK"]
JRST LISP2A
LSH 2,-↑D22
CAIN 2,"S>"
JRST RESETE
LISP2S:
MOVE 1,[SIXBIT /LISP/]
SETNM
>
LISP0C: JRST RESETE
LISP2A: CAME 1,["<SUBS"]
IFE TEN50,<
JRST LISP2S
LSH 2,-↑D22
CAIN 2,"YS"
JRST RESETE
JRST LISP2S
>
;INITIAL ENTRY - INITIALIZATION
LISP1: SETZM TYPTAB ;ZERO TEMP STORAGE PAGE
MOVE 1,[XWD TYPTAB,TYPTAB+1]
BLT 1,BGNCOR-1
MOVE 1,BGNCOR ;ASSIGN FIRST DATA PAGES TO STACKS
MOVEI CP,-1(1)
HRLI CP,-NCP+NREDCP+2
MOVEM CP,ICP ;SAVE INITIAL VALUE
MOVEI PP,NCP-1(1)
HRLI PP,-NPP+NREDPP+2
MOVEM PP,IPP
ADDI 1,NCP+NPP+NPS
MOVEM 1,ENDCOR
SUBI 1,1
IFE TEN50,<
SETZM 0(1) ;MAKE PAGE EXIST
SUBI 1,105
MOVEM 1,FTRAP ;MAGIC FREE VAR TRAP LOC
HRLI 1,20
MOVEM 1,IFTRAP ;INDIRECT VERSION OF ABOVE
MOVEI 1,0(1)
>
LSH 1,-LPS
MOVEM 1,PPTRP ;READ ONLY PAGE TO CATCH PP OVF
;..IN TEN50 JUST USED BY GC
JSP 7,SETSPC
MOVSI F,1 ;FLAGS
MOVE 1,POPDSP ;SETUP UUO DISPATCH
MOVEM 1,41
MOVEI 1,LISP2
HRRM 1,EVEC ;RESET ENTRY VECTOR
IFE TEN50,<
MOVE 1,SYSBFP
MOVEM 1,CSYSBP
MOVE 1,SLNBFP
MOVEM 1,CSLNBP
>
MOVE CP,IIP
IFN TEN50,<
CALL FINIT ;INIT FILE PACKAGE
MOVE 1,[SIXBIT /TTY/] ;OPEN TTY FILES
MOVEI 4,0
CALL INFIL
JRST 4,.
MOVEM 1,FILEN
MOVE 1,[SIXBIT /TTY/]
MOVEI 4,0
CALL OUTFIL
JRST 4,.
MOVEM 1,FILEN+1
MOVEI 1,RSTRT ;ADDRESS FOR INTERRUPT CHARACTER RESTART
HRRM 1,JOBREN
>
IFE TEN50,<
MOVEI 1,100 ;SETUP PRIMARY FILES
MOVEM 1,FILEN
CALL SETMOD ;SET TTY MODES
MOVEI 1,101
MOVEM 1,FILEN+1
>
MOVSI 1,200000
MOVEM 1,FCHAR+1
MOVSI 1,400000
MOVEM 1,FCHAR
;INIT STORAGE
SETZM EVATAB ;CLEAR EVATAB
MOVE 1,[EVATAB,,EVATAB+1]
BLT 1,EVATAB+MTYPN
MOVE 2,[XWD -NTIE,TYPTE];SET UP EVATAB
MOVE 1,(2)
SETOM EVATAB(1)
AOBJN 2,.-2
MOVSI 5,-IST1N ;SETUP PRE-DEFINED PAGES
MOVEI 4,0
IS1: MOVEI 3,0
HLRZ 2,IST1(5) ;SIZE OF PRE-DEFINED SPACE
HRRZ 1,IST1(5) ; TYPE NUMBER FOR SPACE
HRRM 1,TYPTAB(4) ;STORE TYPE NUMBER IN TABLE
ADDI 4,1 ;COUNT INDEX OF TYPE TABLE
ADDI 3,NPS ;COUNT WORDS IN SPACE
CAIGE 3,0(2) ;DONE SUFFICIENT WORDS?
JRST .-4 ;NO
AOBJN 5,IS1 ;DO NEXT SPACE
MOVEI 1,BLOCKT ;SET TYPE FOR REMAINING LOW CODE AND STACKS
MOVE 3,ENDCOR
LSH 3,-LPS
MOVEM 1,TYPTAB(4)
ADDI 4,1
CAIGE 4,0(3)
JRST .-3
;INIT ATOM HASH TABLE
ISHT: MOVEI 7,NHT ;NUMBER OF PAGES IN HT
MOVEM 7,NHP
MOVEI 6,HASHTT
ISHT1: CALL GETPG
HALTF
MOVEM 1,ATOMHT(7)
LSH 1,-LPS
MOVEM 6,TYPTAB(1)
SOJG 7,ISHT1
MOVEI 2,NHT*NPS-1 ;SIZE OF TABLE
MOVEM 2,ATOMHT ;TO FIRST WD OF TABLE OF PAGES
MOVEI 1,2 ;SET MINHT - # OF PAGES TO ADD ON REHASH
MOVEM 1,MINHT
;INIT LIST PAGES ETC.
CALL GCI
;INITIALIZE PARAMETERS
DEFINE INITI (A,B)
< MOVEI 1,B
MOVEM 1,A>
RADIX 10
SETZM FR ;STANDARD INPUT AND OUTPUT FILES
SETZM BSTAB
INITI FP,1
SETOM RMONF
SETOM ESCONF
INITI MAXATL,NATMC
INITI LINSIZ,70
INITI URADIX,10
INITI PPLVL,10000
RADIX 8
MOVSI 1,4000
MOVEM 1,FLTFMC
MOVE 1,CTCTP ;SET STANDARD INTERRUPT CHARS
MOVE 2,OCTCT-CTCT(1)
MOVEM 2,(1)
AOBJN 1,.-2
;INITIALIZE ATOMS
ATSET: MOVEI 6,IATOMS
MOVEI 1,NIATOM
PUSH CP,1
ATSET2: CALL PACS
HRLI 6,440600
ATSET3: ILDB 1,6
JUMPE 1,ATSET1 ;STRING TERMINATED WITH 0
ADDI 1,40 ;CONVERT TO ASCII
CALL PAC
JRST ATSET3
ATSET1: PUSH CP,6
CALL MKATM
POP CP,6
MOVE 2,1(6) ;XWD F,L
TRNE 2,-1
MOVEM 1,0(2) ;CELL TO CONTAIN ATOM
TLNN 2,-1 ;FUNCTION?
JRST ATSET4 ;NO
MOVE 3,2(6) ;XWD NA*40,TYP*1000
ADDI 3,<HCCALV>B26 ;SUBR INSTR 0-3
TLO 3,0(3) ;TO LEFT
HLR 3,2 ;FN ADDR
MOVEM 3,1(1) ;TO FN CELL
ATSET4: ADDI 6,3
SOSLE 0(CP)
JRST ATSET2
POP CP,1 ;FLUSH COUNT
MOVE 1,KNIL ;FINISH SETUP OF EARLY ATOMS
HRRM 1,0(1)
HRLM 1,0(1)
HRRM 1,1(1) ;CAR, CDR, AND FN OF NIL
HRRM 1,@KPRXFL
MOVE 1,KNOB
HRRM 1,0(1) ;CAR OF NOBIND
MOVE 1,KT
HRRM 1,0(1) ;VALUE OF T
HRRM 1,FILEA ;FILL IN CONTROL FILE NAMES
HRRM 1,FILEA+1
HRRZM 1,HLDMSG
HLLZS @KSYSHS
SETOM FREBRK
MOVEI 1,ASZ+50
HRRZM 1,GCMESF
CALL CLRBUF
MOVEM F,TFLGS
JRST LISP2
LISPM1: SIXBIT '$SPAGHETTILISP-10 09-30-75 .../'
;GET C(7) PAGES AND SET TYPE TO C(6)
ISTYP: CALL GETPG
HALTF ;NO CORE
LSH 1,-LPS
MOVEM 6,TYPTAB(1)
SOJG 7,ISTYP
RET
;SETUP STACK CONSTANTS FROM INITIAL POINTERS
SETSPC: HLRZ 1,IPP ;COUNT (NEG)
SUB 1,IPP ;GIVES -(BGN+SIZ)
HRLI 1,PP ;USED AS INDEX
MOVEM 1,IPPC
MOVN 1,1
MOVSI 2,STKEND
HRRI 2,1(1)
MOVEM 2,1(1) ;POINT TO NEXT(EMERGENCY) REGION
MOVE 3,[XWD STKHOL,NREDPP]
MOVEM 3,2(1)
MOVEI 1,1(1)
MOVEM 1,IREDPP
MOVSI 2,STKEND
MOVEM 2,NREDPP+1(1)
HLRZ 1,ICP ;SAME FOR CP
SUB 1,ICP
HRLI 1,CP
MOVEM 1,ICPC
MOVN 1,1
HRRI 2,1(1)
MOVEM 2,1(1)
HRRI 3,NREDCP
MOVEM 3,2(1)
MOVEI 1,1(1)
MOVEM 1,IREDCP
MOVSI 2,STKEND
MOVEM 2,NREDCP+1(1)
JRST 0(7)
IFE TEN50,<
SETMOD: SETZM INCTLA ;MAKE SURE ↑A FLAG IS OFF
HRRZ 3,TTYTBL
MOVEI 1,100
RFMOD
TRZ 2,77B23+3B25+17B29
IORI 2,16B23+2B25+5B31 ;SET WAKEUP,ECHO,RAISE,AND ASCII
TLZ F,LBFFLG+RASFLG
SKIPN LBFLGW(3) ;LINE BUFFERING?
JRST .+3 ;YES
TLO F,LBFFLG ;NO - SET FLAGS WORD
TRO 2,10000 ;NO - WAKEUP ON ALPHABETIC ALSO
SKIPN ECHMDW(3) ;ECHO INPUT?
TRZ 2,2B25 ;NO
SKIPLE 4,RASMOD(3) ;INTERNAL RAISE?
TLO F,RASFLG ;YES
SKIPE 4 ;RAISE AT 10X LEVEL?
TRZ 2,1B31 ;NO
SFMOD
MOVEI 1,-1 ;SET THE ACTUAL TTY
STPAR
MOVEI 1,100
MOVE 2,CCOCW1(3)
MOVE 3,CCOCW2(3)
SFCOC
RET
SETINT: MOVEI 1,400000 ;THIS FORK
EIR
MOVE 2,[XWD LEVTAB,CHNTAB]
SIR ;INIT PSI SYSTEM
MOVE 2,AICC
AIC ;ACTIVATE CHANNELS
MOVE 7,CTCTP
MOVE 1,0(7) ;CHARACTER AND CHANNEL
TRZ 1,400000 ;CLEAR "HARD" BIT
TLNN 1,400000 ;IS CHAR REALLY THERE?
ATI ;YES - ACTIVATE TERMINAL INTERRUPT
AOBJN 7,.-4
RET
CTRLC: MOVSI 1,400000
MOVSI 3,400000
EPCAP ;ENABLE ABILITY TO
MOVE 1,CTCTC ;ACTIVATE CONTROL C
ATI
JRST FALSE
AICC: XWD 770407,447777
SETTRP: MOVE 1,PPTRP
HRLI 1,400000
RMAP
TLNN 2,10000 ;PAGE EXISTS?
JRST STRP1
JUMPL 1,STRP1
MOVE 2,PPTRP
HRLI 2,400000
MOVNI 3,1
AOBJN 3,.+1
CAIE 3,0 ;KI-10 SET TO NO ACCESS
MOVSI 3,20000 ;XCT ACCESS
PMAP
RET
STRP1: SETZM @FTRAP ;MAKE TO EXIST
JRST SETTRP
> ;END OF IFE TEN50
U PPTRP
U FTRAP
U IFTRAP
;GET NEW PAGE AND INCREASE ENDCOR
GETPG: MOVEI 1,NPS
ADD 1,ENDCOR
MOVEI 2,-1(1) ;LAST WORD ON PAGE BEING ASSIGNED
IFN TEN50,<
CAMG 2,JOBREL ;CORE ALREADY ASSIGNED?
JRST GETPG1 ;YES
CORE ;NO, REQUEST MORE FROM SYSTEM
RET ;REFUSED, RETURN NO SKIP
GETPG1: HRRM 1,JOBFF ;FOR CROCK SAVE COMMAND
HRLM 1,JOBSA ;DITTO
>
CAILE 1,777000
RET ;DONT ASSIGN LAST PAGES
EXCH 1,ENDCOR
MOVSI 2,0(1)
HRRI 2,1(1)
SETZM 0(1)
BLT 2,NPS-1(1) ;ZERO PAGE JUST ASSIGNED
JRST RSKIP ;RETURN GOOD
SAV27: EXCH 7,0(CP) ;SAVE AC'S 2-7
PUSH CP,2
PUSH CP,3
PUSH CP,4
PUSH CP,5
PUSH CP,6
JRST 0(7)
RES27: POP CP,7 ;RESTORE AC'S 2-7
POP CP,6
POP CP,5
POP CP,4
POP CP,3
POP CP,2
EXCH 7,0(CP)
POPJ CP,
;INITIALIZATION TABLES
;SYSTEM-DEFINED TYPE NUMBERS
DEFINE TYP (A,B)
< NTYPES==NTYPES+1
A==B
XWD 0,B>
NTYPES=0
TYPTI: TYP ARRAYT,1
TYP BLOCKT,2
TYP STACKT,2
TYP HANDLT,4
TYP STKPT,5
TYP CCODET,1
TYP BTABT,6
TYP HASHTT,7
TYPTE: TYP LISTT,10
TYP VCELLT,11
TYP ATOMT,14
TYP FLOATT,20
TYP FIXT,22
TYP SMALLT,24
NTIE==.-TYPTE
TYP STPTT,30
TYP CHART,32
TYP PNAMT,34
TYP STRNGT,36
IST1: XWD NCHRS,CHART
XWD MSN,SMALLT
IST1N==.-IST1